合并当前工作簿下的所有工作表

Option Explicit

Sub hbgzb()
    
    Dim sh As Worksheet, flag As Boolean
    Dim i As Single, hrow As Single, hrowc As Single

    flag = False
    
    For i = 1 To Sheets.Count
        If Sheets(i).Name = "AllSheets" Then flag = True
    Next
    
    If flag = False Then
        Set sh = Worksheets.Add
        sh.Name = "AllSheets"
        Sheets("AllSheets").Move after:=Sheets(Sheets.Count)
    End If

    For i = 1 To Sheets.Count
        If Sheets(i).Name <> "AllSheets" Then
            hrow = Sheets("AllSheets").UsedRange.Row
            hrowc = Sheets("AllSheets").UsedRange.Rows.Count
            
            If hrowc = 1 Then
                Sheets(i).UsedRange.Copy Sheets("AllSheets").Cells(hrow, 1).End(xlUp)
            Else
                Sheets(i).UsedRange.Copy Sheets("AllSheets").Cells(hrow + hrowc - 1, 1).Offset(1, 0)
            End If
            
        End If
    Next i
    
    MsgBox ("Complted ... OK ")
    

End Sub

中文版支持的 .... 


Option Explicit

Sub hbgzb()
    
    Dim sh As Worksheet, flag As Boolean
    Dim i As Single, hrow As Single, hrowc As Single

    flag = False
    
    For i = 1 To Sheets.Count
        If Sheets(i).Name = "合并数据" Then flag = True
    Next
    
    If flag = False Then
        Set sh = Worksheets.Add
        sh.Name = "合并数据"
        Sheets("合并数据").Move after:=Sheets(Sheets.Count)
    End If

    For i = 1 To Sheets.Count
        If Sheets(i).Name <> "合并数据" Then
            hrow = Sheets("合并数据").UsedRange.Row
            hrowc = Sheets("合并数据").UsedRange.Rows.Count
            
            If hrowc = 1 Then
                Sheets(i).UsedRange.Copy Sheets("合并数据").Cells(hrow, 1).End(xlUp)
            Else
                Sheets(i).UsedRange.Copy Sheets("合并数据").Cells(hrow + hrowc - 1, 1).Offset(1, 0)
            End If
            
        End If
    Next i
    
    MsgBox ("任务已完成")
    

End Sub