修改代码合并多工作簿中指定工作表

huaichuan1

Sub mergeonexls() '合并多工作簿中指定工作表

On Error Resume Next

Dim x As Variant, x1 As Variant, w As Workbook, wsh As Worksheet

Dim t As Workbook, ts As Worksheet, l As Integer, h As Long

Application.ScreenUpdating = False

Application.DisplayAlerts = False

x = Application.GetOpenFilename(FileFilter:="Excel文件 (*.xls; *.xlsx),*.xls; *.xlsx,所有文件(*.*),*.*", _

       Title:="Excel选择", MultiSelect:=True)

Set t = ThisWorkbook

Set ts = t.Sheets(1) '指定合并到的工作表，这里是第一张工作表

l = ts.UsedRange.SpecialCells(xlCellTypeLastCell).Column

For Each x1 In x

If x1 <> False Then

Set w = Workbooks.Open(x1)

Set wsh = w.Sheets(1) '指定所需合并工作表，这里是第一张工作表

h = ts.UsedRange.SpecialCells(xlCellTypeLastCell).Row

If l = 1 And h = 1 And ts.Cells(1, 1) = "" Then

wsh.UsedRange.Copy ts.Cells(1, 1)

Else

wsh.UsedRange.Copy ts.Cells(h + 1, 1)

End If

w.Close

End If

Next

Application.ScreenUpdating = True

Application.DisplayAlerts = True

End Sub

希望a列加入工作薄的名称 新建文件夹.zip (50.87 KB, 下载次数: 0) 代码是网上找来的VBA不会编辑谢谢了

opiona

http://club.excelhome.net/thread-1409141-1-1.html

huaichuan1

opiona 发表于 2018-7-18 12:56
http://club.excelhome.net/thread-1409141-1-1.html

老师我试了 你给的例子也会出线排序问题，给的顺序是1.1-1.10的顺序，而不是1.1-1.2的顺序，能帮我修改一下上面的代码吗

opiona

排序解决比较麻烦，需要添加辅助的东西！

huaichuan1

opiona 发表于 2018-7-18 14:44
排序解决比较麻烦，需要添加辅助的东西！

您看看我这个代码顺序是没问题的，只是不知道汇总的工作簿名字  找起来很麻烦

huaichuan1

opiona 发表于 2018-7-18 14:44
排序解决比较麻烦，需要添加辅助的东西！

工作簿名字添加在a列也行，做一个小标题也行

真实数据是历年的台账数据量很大为了对比查错用的

opiona

huaichuan1 发表于 2018-7-18 14:35
老师我试了 你给的例子也会出线排序问题，给的顺序是1.1-1.10的顺序，而不是1.1-1.2的顺序，能帮我修改一 ...

VBA本身就是这样排序的，y和windows规则不一样

huaichuan1

opiona 发表于 2018-7-18 15:08
VBA本身就是这样排序的，y和windows规则不一样

我这个代码的排序没有问题，只是没有名字