excel多个工作表合并为一个工作表Merge Excel Files14.9.6，超级好用

aoyabing

再发一代码，合并同一目录下多个单独excel报表到同一表中，只保留一个表头

Sub 合并当前目录下所有工作簿的全部工作表()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xls")
AWbName = ActiveWorkbook.Name
Num = 0
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
Num = Num + 1
With Workbooks(1).ActiveSheet
If Num = 1 Then
For G = 1 To Sheets.Count
Wb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1)
Next
Else
For G = 1 To Sheets.Count
Wb.Sheets(G).UsedRange.Offset(1, 0).Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1)
Next
End If
WbN = WbN & Chr(13) & Wb.Name
Wb.Close False
End With
End If
MyName = Dir
Loop
Range("A1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub

使用说明：
新建一个工作表，命名后保存到和欲合并的几个文件同一个文件夹内，按 alt + f11,双击工程资源管理器里面的sheet1(sheet1),在右侧的代码区粘贴如下代码。运行。等候一会就OK了。
补充一下：表中不能有空行空列。

aoyabing

你是棉花 发表于 2020-6-17 08:02
试过，貌似没任何反应

注意应用条件，按要求操作

aoyabing

还有对一个表，类似于总表，按某列拆分为单个的表的代码：
Sub 保留表头拆分以表头命名新工作簿()
    Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
    c = Application.InputBox("请输入拆分列号数字", , 24, , , , , 1)
    If c = 0 Then Exit Sub
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    arr = [a1].CurrentRegion
    lc = UBound(arr, 2)
    Set rng = [a1].Resize(, lc)
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        If Not d.Exists(arr(i, c)) Then
            Set d(arr(i, c)) = Cells(i, 1).Resize(1, lc)
        Else
            Set d(arr(i, c)) = Union(d(arr(i, c)), Cells(i, 1).Resize(1, lc))
        End If
    Next
    k = d.Keys
    t = d.Items
    For i = 0 To d.Count - 1
        With Workbooks.Add(xlWBATWorksheet)
            rng.Copy .Sheets(1).[a1]
            t(i).Copy .Sheets(1).[a2]
            .SaveAs Filename:=ThisWorkbook.Path & "\" & k(i) & ".xls"
            .Close
        End With
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "拆分结束"
End Sub

特别说明：
输入的拆分列为数字：如A列为1，B列为2，依次类推。且有信息的行或列对应表头不能为空。
A        1
B        2
C        3
D        4
E        5
F        6
G        7
H        8
I        9
J        10
K        11
L        12
M        13
N        14
O        15
P        16
Q        17
R        18
S        19
T        20
U        21
V        22
W        23
X        24
Y        25
Z        26

aoyabing

烟雨成林 发表于 2020-6-21 07:41
为啥你好像这么了解这个软件

我也是在这里下载并第一次使用这个软件，之前用VBA代码。如果有80张表头相同的表要合并，用这个软件合并后就保留80个表头，实际上还要手动去掉79个，也挺麻烦的，如果用代码则可以做到只保留一个表头。当然只有几张十几张表合并用这个也挺方便，手动工作量少些。

aoyabing

aoyabing 发表于 2020-6-16 15:23
测试了一下，表头相同，但合并后保留了每个表的表头，见下图：

如果是这样，用以下代码解决：

Sub 合并当前工作簿下的所有工作表()
Application.ScreenUpdating = False
For j = 1 To Sheets.Count
   If Sheets(j).Name <> ActiveSheet.Name Then
       X = Range("A65536").End(xlUp).Row + 1
       Sheets(j).UsedRange.Copy Cells(X, 1)
   End If
Next
Range("B1").Select
Application.ScreenUpdating = True
MsgBox "当前工作簿下的全部工作表已经合并完毕！", vbInformation, "提示"
End Sub

即用这个代码也是合并后且保留每个表的表头。
补充一下：表中不能有空行空列。

bazinga909

感谢分享

bazinga909

链接。。。。？

无敌小儿

附件在哪呢

kosky1987

这个比较实用，楼主链接没有

tyhsg

链接在哪里

szair

没有米啊？米在哪里？大家的锅都在等着

倩倩威武

好用！求下载链接~~~~

bsjasd

连接在哪呢