الـعيدروس

وهذا كود تغير اسم الورقة النشطة Sub Renamed_SH() alidroos_sh = Application.Dialogs(xlDialogWorkbookName).Show End Sub

او بنفس حلقة تكرار الترحيل هكذا Sub Khboor_Tarheel() On Error Resume Next Application.ScreenUpdating = False For a = 5 To [C200].End(xlUp).Row If Cells(a, 3) <> "" Then MySheets = Cells(a, 3) With Sheets(MySheets).[B200].End(xlUp) .Offset(1, 0) = Cells(a, 4) .Offset(1, 1) = Cells(a, 5) .Offset(1, 2) = Cells(a, 6) .Offset(1, 3) = Cells(a, 7) End With End If If Cells(a, 3) > "" Then Cells(a, 4).Resize(1, 4).Value = "" Next a Application.ScreenUpdating = True MsgBox "!تم الترحيل بنجاح", vbInformation + vbMsgBoxRight, "تم الترحيل" Range("C5").Select On Error GoTo 0 End Sub الفرغه تعمل عمايل

ارفق مثال يااخي اسماء الشيتات مثلا ملف اكسل الرئيسي : وهذا الملف ماهو الشيت والمدى المعني المراد ترحيله الى الملفات الباقية ملف اكسل ترحيل 1 ملف اكسل ترحيل 2 هذا مااقصده كي يتضح المطلوب اكثر

استاذي القدير عبدالله المجرب لك مثل دعائك اضعاف مضاعفه قل امين تسلم على هذا التشجيع

وهذا حل اخر ملخص Sub Khboor_Tarheel() On Error Resume Next Application.ScreenUpdating = False For A = 5 To [C200].End(xlUp).Row If Cells(A, 3) <> "" Then MySheets = Cells(A, 3) With Sheets(MySheets).[B200].End(xlUp) .Offset(1, 0) = Cells(A, 4) .Offset(1, 1) = Cells(A, 5) .Offset(1, 2) = Cells(A, 6) .Offset(1, 3) = Cells(A, 7) End With End If Next A Application.ScreenUpdating = True MsgBox "!تم الترحيل بنجاح", vbInformation + vbMsgBoxRight, "تم الترحيل" Range("C5").Select On Error Resume Next On Error GoTo 0 '============================================================================= For i = 5 To 1000 If Sheets("ورقة1").Cells(i, "c") > "" Then Cells(i, 3).Resize(1, 4).Value = "" Next i End Sub

السلام عليكم الاستاذ الحبيب احمد حمور ابو عبدالله اولاً اين الغيبات يارجل يامطول الغيبات اين الغنايم لك وحشة واشكرك على التجربة هذا ماتعلمنها من دروسكم وبالاحرا نقلدكم جزاك الله خير

السلام عليكم ماشاء الله كود مختصر وجميل بارك الله فيك كل يوم نستفيد منك (يادينمو المنتدى) ومع البهارات(دينمو اتوماتيك) تحياتي

ما المطلوب ماهو شرط جلب البيانات هل هو عمود الاوردر بمجرد كتابتة في عمود A + المواد و + اسم القائم بالاعداد ام ماذا

السلام عليكم اخي الفاضل الله لايهينك سوي فولدر وحط عليه عدد الملفات اسماء وهميه وتحديد المدى المراد ترحيلة من ملف الى باقي الملفات وشرح بسيط كي نقدر نساعدك وطلبك ليس صعب امام قدرة العباقرة في هذا المنتدى العظيم

اين الملف يامان لايوجد

اخي الفاضل تم عمل المطلوب بالمقدور عليه اضطررت لعمل معادلة في عمود A وهذا هو الكود Sub Khboor_Tarheel() On Error Resume Next Application.ScreenUpdating = False For A = 5 To [C200].End(xlUp).Row If Cells(A, 3) <> "" Then MySheets = Cells(A, 3) With Sheets(MySheets).[B200].End(xlUp) .Offset(1, 0) = Cells(A, 4) .Offset(1, 1) = Cells(A, 5) .Offset(1, 2) = Cells(A, 6) .Offset(1, 3) = Cells(A, 7) End With End If Next A Application.ScreenUpdating = True MsgBox "!تم الترحيل بنجاح", vbInformation + vbMsgBoxRight, "تم الترحيل" Range("C5").Select Sheets("ورقة1").Activate Application.ScreenUpdating = False Application.EnableEvents = False On Error Resume Next Dim rngData As Range Dim rngRow As Range Set rngData = ورقة1.Range("a5:a1000") For Each rngRow In rngData.Rows If Application.WorksheetFunction.CountIf(Sheets("ورقة1").Range("a5:a1000"), Cells(rngRow, 1)) < 0 Then rngRow.Select Else rngRow.Offset(0, 3).Resize(1, 3).ClearContents End If Next rngRow Application.ScreenUpdating = True Application.EnableEvents = True On Error GoTo 0 End Sub وهذا المرفق مصنف_alidroos.rar

الكود لايوجد به ترحيل مخصص اذا كنت تقصد انك تريد تحديد الصف المراد ترحيله ومن ثم مسح بيانات الصف بعد الترحيل بمعنى اضافة على الكود هذا شي اخر ارجو التوضيح

السلام عليكم او هكذا Sub Khboor_Tarheel() On Error Resume Next Application.ScreenUpdating = False For A = 5 To [C200].End(xlUp).Row If Cells(A, 3) <> "" Then MySheets = Cells(A, 3) With Sheets(MySheets).[B200].End(xlUp) .Offset(1, 0) = Cells(A, 4) .Offset(1, 1) = Cells(A, 5) .Offset(1, 2) = Cells(A, 6) .Offset(1, 3) = Cells(A, 7) End With End If Next A Application.ScreenUpdating = True MsgBox "!تم الترحيل بنجاح", vbInformation + vbMsgBoxRight, "تم الترحيل" Range("C5").Select last = WorksheetFunction.CountA(Range("d:f")) row_1 = "d5:f" & last Range(row_1).ClearContents On Error GoTo 0 End Sub

لن اتركك حتى يزبط معاك وجرب هذا المرفق مع اضافة المعادلة اوتماتيك في الصنف الجديد في ورقة store تحياتي DATA_RFRE_ALS.rar

السلام عليكم جربت مرفق المشاركة السايقة لم يقوم بترحيل الغير موجود في ورقة المخزن اعدته الى الاسم السابق store احتمال اثابت متغير ولاكن مااعرفه عن اثبات متغير اذا كانت هذه الجملة موجوده في اول الاكواد Option Explicit ولاكن انا لم ابرزها عشان كذا لاتوجد مشكلة من ناحية اثبات متغير والله اعلم تفضل المرفق بعد استرجاع اسم الورقة في كل الاكواد DATA_RFRE3.rar

الاغرب من هذا تجربتي للملف بأكثر من جهاز وشغال زي الحلاوى ولاكن ارجو من الاخوة الافاضل من صادفتة نفس المشكلة ان يشعرنا عشان نعرف اين المشكلة ربما يكون من الاوفيس الذي عندك او احد المكتبات عندك مفقودة تحياتي

اها المشكلة التي ظهرت بسبب تغير اسم الورقة لاعليك جرب المرفق غيرت اسم الورقة بالاسم الاساسي DATA_RFRE2.rar

استااااذ سعد عابد حلاوى بس فله منوره هكذا والا فلا اتحفنا بالجديد زادك الله علما الى الامام تقبل مروري

تسلم على الهدية الجميلة اننا نحب الهدايا نرجو مزيد من الهدايا والى الامام

لاعليك اخي عبدالقادر تعبك راحه نحنو تحت امر اهالي البلد الطيبه تفضل جرب وبلغني هل زبط ام لا DATA_RFRE1.rar

السلام عليكم جزاك الله الف خير استاذ دغيدي ولاثراء الموضوع هذا كود اخر اولاً استخدم هذا الكود لقراءة رقم ID الهارد ثم اكتب الايدي في مذكرة رقم الايدي نفسه اذا كانت الحروف كبتل عادة بيكون كبتل مع ارقام هذا الكود Sub code_HARD() With CreateObject("Scripting.FileSystemObject") MsgBox Hex(.Drives.Item("c:").SerialNumber) End With End Sub وبعد حفظ رقم الايدي حط هذا الكود في حدث ThisWorkbook Private Sub Workbook_Open() With CreateObject("Scripting.FileSystemObject") If Hex(.Drives.Item("c:").SerialNumber) = "F0E1D85C" Then MsgBox "تفضل بالدخول" Else: MsgBox "نأسف هذا البرنامج مخصص لجهاز اخر " ThisWorkbook.Close savechanges = True End If End With End Sub استبدل الايدي الذي في الشرط بالايدي المحفوظ من هذا السطر المشار باللون الاحمر If Hex(.Drives.Item("c:").SerialNumber) = "[color=#ff0000]F0E1D85C[/color]" Then الية الكود اذا حاولت استخدام الملف في جهاز اخر لن يفتح لان رقم الايدي غير مطابق والسلام عليكم

ارجو منك ارفاق الملف لكي يتم التعديل عليه وسوف اوضح لك ماتم تعديله تحياتي

بعد اذن استاذنا الحبيب عبدالله المجرب تفضل Book1.rar

الاخ الاستاذ ياسر الحافظ الاخ الاستاذ سعد عابد مااستفدناه منكم اكثر مروركم اسعدني جدا

اذهب الى قائمة References وحفز على هذا الامر Microsoft Data Formatting Object Library عله يفيد والله اعلم