1. 同一目录下的多工作簿，每个工作簿中有一张或多张工作表，一键全部汇总

Sub 合并目录所有工作簿全部工作表()

Dim MP, MN, AW, Wbn, wn

Dim Wb As Workbook

Dim i, a, b, d, c, e

Application.ScreenUpdating = False

MP = ActiveWorkbook.Path

MN = Dir(MP & "\" & "*.xls")

AW = ActiveWorkbook.Name

Num = 0

e = 1

Do While MN <> ""

If MN <> AW Then

Set Wb = Workbooks.Open(MP & "\" & MN)

a = a + 1

With Workbooks(1).ActiveSheet

For i = 1 To Sheets.Count

If Sheets(i).Range("a1") <> "" Then

Wb.Sheets(i).Range("a1").Resize(1, Sheets(i).UsedRange.Columns.Count).Copy .Cells(1, 1)

d = Wb.Sheets(i).UsedRange.Columns.Count

c = Wb.Sheets(i).UsedRange.Rows.Count - 1

wn = Wb.Sheets(i).Name

.Cells(1, d + 1) = "表名"

.Cells(e + 1, d + 1).Resize(c, 1) = MN & wn

e = e + c

Wb.Sheets(i).Range("a2").Resize(c, d).Copy .Cells(.Range("a1048576").End(xlUp).Row + 1, 1)

End If

Next

Wbn = Wbn & Chr(13) & Wb.Name

Wb.Close False

End With

End If

MN = Dir

Loop

Range("a1").Select

Application.ScreenUpdating = True

MsgBox "共合并了" & a & "个工作薄下全部工作表。如下：" & Chr(13) & Wbn, vbInformation, "提示"

End Sub

2. 同一工作簿中的多工作表，将指定的多工作表一键汇总

Sub huizongdata()

    Rows("2:10000").Clear
     '第一步是先清空汇总表的数据，这里是从第2行开始清理到10000行，可以自己修改。
     
    Application.Wait Now + TimeValue("00:00:01")   '延迟1秒
    
    Dim st As Worksheet, rng As Range, rrow As Integer, i As Integer
    
    '定义一些需要用到的变量
    
    'For Each st In Worksheets  循环开始，遍历所有的工作表
    For i = 3 To Worksheets.Count
    
        Set st = Sheets(i)
        
        Set rng = Range("A10000").End(xlUp).Offset(1, 0)
        
        '每次循环就动态定位需要拷贝数据的区域，即获得A列第一个空的单元格
        
        rrow = st.Range("A2").CurrentRegion.Rows.Count - 1
        
        '获得每个工作表中的数据记录数，即行数，同时需要减去表头的行数，这里是减掉2行。
        
        st.Range("A2").Resize(rrow, 9).Copy rng
        
        '将数据扩展rows行，4列拷贝到数据，并粘贴到汇总表
    
    Next i
   

End Sub