طلب ترحيل بيانات من اكثر من شيت فى شيت واحد

[محمد نوح]

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

اخواني الكرام

اريد كود VBA يمكنني من دمج عدة شيتات موجودة في نفس الملف فى شيت باسم total بحيث يتم نقل بيانات الشيت الاول ثم يليها بيانات الشيت الثانى وهكذا .

وشكرا جزيلا ....🌷

الرواتب.xlsx

[محمد هشام.]

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

Sub MergeTotal()
    Dim WS As Worksheet, crWS As Worksheet, LastRow As Long, Irow As Long
    
    On Error Resume Next
    Set crWS = Sheets("total")
    On Error GoTo 0
    
    If crWS Is Nothing Then
    MsgBox " غير موجودة total ورقة ", vbInformation
        Exit Sub
    Else
     Application.ScreenUpdating = False
        crWS.Range("A2:O" & crWS.Rows.Count).Clear
    End If

    Irow = 2
    For Each WS In ThisWorkbook.Sheets
        If WS.Name <> crWS.Name Then
            LastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row
            If LastRow >= 2 Then
                WS.Range("A2:O" & LastRow).Copy
                crWS.Cells(Irow, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
                Irow = crWS.Cells(crWS.Rows.Count, 1).End(xlUp).Row + 1
            End If
        End If
    Next WS

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

or

Sub MergeTotal()
    Dim WS As Worksheet, Src As Worksheet
    Dim OnRng As Variant, rng As Range, r As Range
    Dim lastRow As Long, tmp As Long, col As Integer
    
    Set WS = Sheets("total")
    Application.ScreenUpdating = False
    lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row
    
    If lastRow > 1 Then: WS.Rows("2:" & lastRow).Clear
    tmp = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1
    
    For Each Src In ThisWorkbook.Sheets
        If Src.Name <> WS.Name Then
            OnRng = Src.Range("A2:O" & Src.Cells(Src.Rows.Count, "A").End(xlUp).Row).Value
            WS.Cells(tmp, 1).Resize(UBound(OnRng, 1), UBound(OnRng, 2)).Value = OnRng
            For lastRow = 1 To Src.Cells(Src.Rows.Count, "A").End(xlUp).Row
                WS.Rows(tmp + lastRow - 1).RowHeight = 18.5
            Next lastRow
            tmp = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1
        End If
    Next Src
    
    With WS.Range("A1:O" & WS.Cells(WS.Rows.Count, "A").End(xlUp).Row)
        .Borders.LineStyle = xlContinuous: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter
    End With

    Application.ScreenUpdating = True
End Sub

الرواتب.xlsb

تم تعديل ديسمبر 21, 2024 بواسطه محمد هشام.

[محمد نوح]

اخى الكريم محمد هشام شكرا جزيلا على مجهودك تم تجربه  الملف والكود يعمل بشكل سليم 👍👍👍