تلخيص وتكرار جميع الاوراق في ورقة واحدة

[B.kadri]

السلام عليكم 

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

ولكم جزيل الشكر ،،

Book1.xlsx

[عبدالله بشير عبدالله]

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

الكود 

Sub تجميع_البيانات()
    Dim wsSummary As Worksheet
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim summaryLastRow As Long
    Dim dataRange As Range
    On Error Resume Next
    Set wsSummary = ThisWorkbook.Sheets("ملخص")
    On Error GoTo 0

    If wsSummary Is Nothing Then
        Set wsSummary = ThisWorkbook.Sheets.Add
        wsSummary.Name = "ملخص"
    End If

    wsSummary.Rows("3:" & wsSummary.Rows.Count).ClearContents
    summaryLastRow = 3

    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> wsSummary.Name Then
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            
            If lastRow >= 3 Then
                Set dataRange = ws.Range("A3:Q" & lastRow)
                wsSummary.Cells(summaryLastRow, "A").Resize(dataRange.Rows.Count, dataRange.Columns.Count).Value = dataRange.Value
                summaryLastRow = summaryLastRow + dataRange.Rows.Count
            End If
        End If
    Next ws

    MsgBox "تم تجميع البيانات !", vbInformation
End Sub

الملف 

Book1.xlsb

 

[محمد هشام.]

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

Option Explicit
Sub CopyData()
    Dim ColArr() As Variant, Irow&, lr&
    Dim OnRng As Range, f As Worksheet
    Dim WS As Worksheet: Set WS = Sheets("ملخص")
    
    Application.ScreenUpdating = False
    WS.Range("A2:Q" & WS.Rows.Count).ClearContents
    For Each f In ThisWorkbook.Sheets
        If f.Name <> WS.Name Then
            Irow = f.Cells(f.Rows.Count, "D").End(xlUp).Row
            If Irow > 2 Then
                If WS.Cells(2, 1).Value = "" Then
                    WS.Range("A2:Q2").Value = f.Range("A2:Q2").Value
                End If
                
                Set OnRng = f.Range("A3:Q" & Irow)
                ColArr = OnRng.Value
                
                lr = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1
                WS.Cells(lr, "A").Resize(UBound(ColArr, 1), UBound(ColArr, 2)).Value = ColArr
            End If
        End If
    Next f
    Application.ScreenUpdating = True
End Sub

 

Book1 v2.xlsb