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

[Mando_Mam]

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

اتمني من الاخوة الكرام مساعدتي في ايجاد حل

عندي ملف شهري يحتوي تقريبا على 100 الف سجل عبارة عن 10 اعمدة بيانات  عملاء

واحتاج ان اقوم بتجميع كل الشهور في ملف واحد للسنة كاملة حتى استطيع عمل تقاريري

(فكرة النسخ واللصق مجهدة نظراً لكبر حجم الملف الشهري)

جزاكم الله خيرا

Book3.xlsm

[Ali Mohamed Ali]

وعليكم السلام-يمكنك استخدام هذا الكود لطلبك

Sub Combine()
    Dim j As Integer
    Dim s As Worksheet
    On Error Resume Next
    Sheets(1).Select
    Worksheets.Add ' add a sheet in first place
    Sheets(1).Name = "Year 2020"
    ' copy headings
    Sheets(1).Activate
    With ActiveSheet
   v = 1
  Range("a2").Resize(v + 1, 10) = arr
    Range("b" & v + 1).FormulaR1C1 = "Total"
      Range("c" & v + 1).FormulaR1C1 = "=SUBTOTAL(9,R4C3:R[-2]C)"
    Range("d" & v + 1).FormulaR1C1 = "=SUBTOTAL(9,R4C4:R[-2]C)"
    Range("e" & v + 1).FormulaR1C1 = "=SUBTOTAL(9,R4C5:R[-2]C)"
    Range("f" & v + 1).FormulaR1C1 = "=SUBTOTAL(9,R4C6:R[-2]C)"
    Range("g" & v + 1).FormulaR1C1 = "=SUBTOTAL(9,R4C7:R[-2]C)"
    Range("h" & v + 1).FormulaR1C1 = "=SUBTOTAL(9,R4C8:R[-2]C)"
    Range("i" & v + 1).FormulaR1C1 = "=SUBTOTAL(9,R4C9:R[-2]C)"
            End With
      Sheet1.Range("b4:k4").Copy Sheets("Year 2020").Range("a3:K3")
    Columns("A:C").ColumnWidth = 10
    Columns("D:I").ColumnWidth = 8
    Columns("J").ColumnWidth = 16
    Range("b4").EntireRow.Select
      Range("b2:i2").Interior.ColorIndex = 5
   Range("a2:j2").Font.ColorIndex = 2
   Range("b2:i2").Font.Bold = True
   Range("b2:i2").Font.Size = 16
   Range("b2:i2").Font.Name = "Times New Roman"
  Range("b2:i2").HorizontalAlignment = xlCenter
       Cells.Rows(4).Font.Bold = True
    Selection.Copy Destination:=Sheets(1).Range("b4")

    For Each s In ActiveWorkbook.Sheets
        If s.Name <> "Year 2020" Then
            Application.Goto Sheets(s.Name).[b4]
            Selection.CurrentRegion.Select
            ' Don't copy the headings
            Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
            Selection.Copy Destination:=Sheets("Year 2020"). _
              Cells(Rows.Count, 1).End(xlUp)(2)
        End If
    Next
End Sub

Book4 .xlsm

[Mando_Mam]

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

انا شاكر جدا جدا لحضرتك استاذنا الفاضل الاستاذ علي محمد 

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

خالص تحياتي،