表头顺序不一样的表格如何合并_怎样合并表头相同的多张excel表格？？？？

本帖最后由 ·#天蝎#· 于 2018-10-20 16:25 编辑

我在网上找了些，加上我自己的修改，试着做了个合并多张表头、格式相同的表格文件的VBA，请各位大侠批评指正。Sub 多工作簿合并()

Dim HeadRows As Byte, ActiveWB As Workbook, cell As Range

Dim bks As Workbook

Dim fdg As FileDialog

Dim FileName$

Dim p As String

UserForm1.ListBox9.Clear

Set fdg = Application.FileDialog(msoFileDialogFilePicker)

With fdg

.Title = "请选择文件(可以多选)"

.AllowMultiSelect = True 'False表示不能选择多个文件,True表示可以选择多个文件

.Filters.Clear

.Filters.Add "表格文件", "*.xls;*.et;*.xlsx"

FileName = .Show

For i = 1 To .SelectedItems.Count

UserForm1.ListBox9.AddItem (.SelectedItems(i))

Next i

End With

If fdg.SelectedItems.Count = 0 Then Exit Sub

Set fdg = Nothing

On Error Resume Next

Set ActiveWB = ActiveWorkbook  '将活动工作簿赋予变量

Set bks = Workbooks.Add

HeadRows = Application.InputBox("请确认待合并工作簿的标题行数，该行将产生在合并工作簿中做为新的标题行：", "标题行", 1, , , , , 1) '让用户指定标题行数，标题不参与合并

If HeadRows < 1 Then Exit Sub  '如果标题行小于1则退出程序

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual '计算模式调用手动，从而提速

For j = 0 To UserForm1.ListBox9.ListCount - 1

UserForm1.ListBox9.ListIndex = j

UserForm1.ListBox9.Selected(j) = True

nm = UserForm1.ListBox9.List(UserForm1.ListBox9.ListIndex, 0)

Workbooks.Open FileName:=nm

bm = ActiveWorkbook.Name

ActiveWB.Activate  '返回存放合并数据的工作表

bks.Worksheets(1).Activate

If j = 1 Then Intersect(Workbooks(nm).Sheets(1).UsedRange, Workbooks(nm).Sheets(1).Rows("1:" & HeadRows)).Copy bks.Worksheets(1).Cells(1, 1) '如果j=1,那么将标题复制到活动工作表a1

For i = 1 To Workbooks(nm).Sheets.Count '遍历所有工作表，开始合并标题以外的数据

With Workbooks(nm).Sheets(i).UsedRange '引用待合并工作簿中每个工作表的已用区域

If Not IsEmpty(Workbooks(nm).Sheets(i).UsedRange) Then '如果非空表

If .Rows.Count <= HeadRows Then GoTo lines  '如果数据行小于等于标题行数则执行下轮循环

Set cell = Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1) '将活动工作表已用区域的下一行第3个单元格赋予变量

Intersect(.Offset(HeadRows, 0), .Cells).Copy cell '将目标数据除标题外全部复制到cell单元格(此次复制，仅仅需要其格式)

End If

Cells.EntireColumn.AutoFit '自动调整行高列宽

End With

lines:

Next i  '合并下一个工作表

Workbooks(nm).Close False '并闭工作簿，且不保存

With UserForm0

.Show 0

.Label2.Width = Int(j / (UserForm1.ListBox9.ListCount - 1) * 282)

.Label3.Caption = bm

.Caption = "正在合并：" & bm

.Label4.Caption = CStr(Int(j / (UserForm1.ListBox9.ListCount - 1) * 100)) + "%"

DoEvents

End With

Next j

MkDir PathStr & "\" & "合并表\"

bks.SaveAs FileName:=PathStr & "\" & "合并表\" & Left(bm, Len(bm) - 4) & "等表合并" & ".et"

bks.Close True

Set bks = Nothing

Unload UserForm0

On Error Resume Next

Application.WindowState = xlMinimized

MsgBox ("请查看合并好的表格！")

Shell "Explorer.exe " & PathStr & "\" & "合并表\", vbMaximizedFocus

UserForm1.Hide

Application.ScreenUpdating = True  '恢复屏幕更新

Application.Calculation = xlCalculationAutomatic  '恢复自动计算

End Sub