مطلوب كود دمج جميع الملفات تحت بعض في شيت جديد ومجلد جديد

[Ahmed Saad 2017]

السلام عليكم ورحمة الله وبركاته

تحية لجميع الأعضاء المحترمين

مطلوب كود الدمج الملفات ذات نفس الاسم بس في فولدرات بأسماء مختلفة في شيت جديد ومجلد جديد أسفل بعض 

Test.zip

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته.

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

Sub Importer_Sheets()
Dim chemin$, dossier, fichier, MH As Worksheet, lig&, i%, h&
chemin = ThisWorkbook.Path & "\"  
dossier = Array("test-01", "test-02", "test-03", "test-04", "test-05", "test-06", "test-07") 'تحديد اسماء الفولدرات
fichier = "Test.xls" 'اسم الملف الهدف
Set MH = ActiveSheet
lig = 4 ' تحديد  اول صف يتم وضع عليه البيانات

Application.ScreenUpdating = False
MH.Rows(lig & ":" & MH.Rows.Count).Delete
For i = 0 To UBound(dossier)
    With Workbooks.Open(chemin & dossier(i) & "\" & fichier).Sheets(1) 'فتح الملف
        
        If .FilterMode Then .ShowAllData 'إذا تم تصفية الورقة
        h = .Range("B" & .Rows.Count).End(xlUp).Row            ' الى غاية الصف الأخير في العمود B
        
        .Rows("1:" & h).Copy MH.Cells(lig, 1)    'نسخ ولصق
        
        lig = lig + h + 3     '3 عدد الصفوف بين كل ورقة عمل
        .Parent.Close False     'اغلاق الملف
    End With
Next
End Sub

بالتوفيق

Test_دمج.zip

تم تعديل يناير 14, 2023 بواسطه Mohamed Hicham