المساعدة فى تنفيذ كود لجلب بيانات من عدة ملفات مفتوحة

[طارق_طلعت]

السادة الأفاضل

ارجو المساعدة فى تنفيذ كود يقوم بترحيل بيانات من الملفات المفتوحة الى ملف "بيانات مجمعة" كالأتى:-

1-يتم ترحيل البيانات من جميع الملفات المفتوحة من شيت "Worksheet" بكل ملف الى ملف "بيانات مجمعة" شيت "بيانات"من بداية البيانات فى اول سطر الى نهايتها فى اخر سطر

2- يتم ترك سطر بين كل بيان و البيان الأخر

3- يتم سحب البيانات من جميع الشيتات المفتوحة بنفس الطريقة

4- عدد الملفات المفتوحة قد يتجاوز ال 100 ملف

5- اسماء الشيتات المفتوحة غير محددة و قد تتغير فى كل مرة

مرفق امثلة للملفات و ملف "بيانات مجمعة" المطلوب الترحيل الية و بة البيانات بعد الترحيل بالطريقة المطلوبة للأيضاح

 

و شكرا جزيلا لتعاونكم

2021-06-20 (1).xlsx 2021-06-20 (3).xlsx 2021-06-20.xlsx بيانات مجمعة.xlsx

تم تعديل يونيو 20, 2021 بواسطه طارق_طلعت

[عبدالفتاح في بي اكسيل]

لا اتخيل  ان جهاز  الكمبيوتر  يحتمل  فتح  اكثر  من 100  ملف !!!!

 

[طارق_طلعت]

شكرا على الرد

يمكن تقسيمهم الى عدة مراحل كل مرحلة 20 ملف مثلا

 

[عبدالفتاح في بي اكسيل]

جرب  هذا  الماكرو 

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

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

 

Sub Consolidation()

Dim CurrentBook As Workbook
Dim WS As Worksheet
Set WS = ThisWorkbook.Sheets("Worksheet")
Dim IndvFiles As FileDialog
Dim FileIdx As Long
Dim i As Integer, x As Integer


With WS

    
    If Len(.Range("a2")) Then
        Intersect(.UsedRange, .UsedRange.Offset(0)).Clear 'removes old data
    End If

End With

Set IndvFiles = Application.FileDialog(msoFileDialogOpen)
With IndvFiles
    .AllowMultiSelect = True
    .Title = "Multi-select target data files:"
    .ButtonName = ""
    .Filters.Clear
    .Filters.Add ".xlsx files", "*.xlsx"
    .Show
End With

Application.DisplayAlerts = False
Application.ScreenUpdating = False

For FileIdx = 1 To IndvFiles.SelectedItems.Count
    Set CurrentBook = Workbooks.Open(IndvFiles.SelectedItems(FileIdx))
    For Each Sheet In CurrentBook.Sheets
        Dim LRow1 As Long
        LRow1 = WS.Range("A" & WS.Rows.Count).End(xlUp).Row + 2
        Dim LRow2 As Long
        LRow2 = CurrentBook.ActiveSheet.Range("A" & CurrentBook.ActiveSheet.Rows.Count).End(xlUp).Row

        Dim ImportRange As Range
        Set ImportRange = CurrentBook.ActiveSheet.Range("A2:F" & LRow2)

        ImportRange.Copy
        WS.Range("A" & LRow1 + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Next
    CurrentBook.Close False
Next FileIdx

Application.DisplayAlerts = True
Application.ScreenUpdating = True


End Sub

 

[عبدالفتاح في بي اكسيل]

قم بادراج موديول في  الملف  التجميعي  وضع  الكود به   

عندما   تقوم  بتحديد  الملفات من  المستعرض  ثم  الضغط  على  فتح  سيقوم  بسحب  البيانات منها   دون  فتح  الملفات  

[طارق_طلعت]

السيد الفاضل استاذ عبد الفتاح

انا جربت الكود و يعمل بشكل ممتاز و يفى بالغرض تماما

شكرا جزيلا على المساعدة جعلة اللة فى ميزان حسناتك