'；将多个工作表中的数据附加到单个工作表宏中

Posted 2021-02-22

'Append data from multiple worksheet to single worksheet macro

'Append data from multiple worksheet to single worksheet macro
Sub CombineData()
 
    Dim wksFirst As Worksheet
    Dim wksLast As Worksheet
    Dim wksDest As Worksheet
    Dim strFirstSht As String
    Dim strLastSht As String
    Dim strDestSht As String
    Dim NextRow As Long
    Dim i As Long
 
    strFirstSht = "Sheet1" 'change the name of the first sheet accordingly
    strLastSht = "Sheet2" 'change the name of the last sheet accordingly
    strDestSht = "Combined Data" 'change the name of the destination sheet accordingly
 
    On Error Resume Next
    Set wksFirst = Worksheets(strFirstSht)
    If wksFirst Is Nothing Then
        MsgBox strFirstSht & " does not exist...", vbInformation
        Exit Sub
    Else
        Set wksLast = Worksheets(strLastSht)
        If wksLast Is Nothing Then
            MsgBox strLastSht & " does not exist...", vbInformation
            Exit Sub
        End If
    End If
    On Error GoTo 0
 
    Application.ScreenUpdating = False
 
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets(strDestSht).Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
 
    Set wksDest = Worksheets.add(Worksheets(1))
 
    wksDest.Name = strDestSht
 
    For i = wksFirst.Index To wksLast.Index
        Worksheets(i).Range("A1:H89").Copy
        With wksDest
            NextRow = .Cells(.Rows.count, "A").End(xlUp).row + 1
            With .Cells(NextRow, "A")
                .PasteSpecial Paste:=8 'column width for Excel 2000 and later
                .PasteSpecial Paste:=xlPasteValues
                .PasteSpecial Paste:=xlPasteFormats
            End With
        End With
    Next i
 
    wksDest.Cells(1).Select
 
    Application.CutCopyMode = False
 
    Application.ScreenUpdating = True
 
End Sub