如何合并不同工作簿中的同名工作表

zhaogang1960

huazai688 发表于 2011-8-25 18:45
对了，合并工作表时最好是数值性粘贴方式，因为实际工作中需要合并的工作表存在公式和宏，如果是原格式带公 ...

Sub combo()
Dim Wk As Workbook, Sht As Worksheet, n As Integer, MyPath, MyName, t%
t = Val(InputBox("请选择工作表序号", , 1))
If t = 0 Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sh In Sheets
    If sh.Name <> ActiveSheet.Name Then sh.Delete
Next
n = 1
MyPath = ThisWorkbook.Path & "\"   '指定路径
MyName = Dir(MyPath & "\" & "*.xls")    '寻找第一项
Do While MyName <> ""    '开始循环
If MyName <> ThisWorkbook.Name Then
Set Wk = Workbooks.Open(MyPath & "\" & MyName)
Wk.Sheets(t).Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) '此处只插个第一个sheet
With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
.Name = Mid(MyName, 1, Len(MyName) - 4) '重新命名sheet
.UsedRange.Value = .UsedRange.Value
End With
Wk.Close False
End If
MyName = Dir    '查找下一个
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

huazai688

谢谢赵老师，已经满足了我的要求。新求助：如果不通过工作表序号，而是通过工作表名称（因为实际工作中每个工作簿的工作表不一样，存在同名，但不一定工作表序号也相同）实现合并，不知代码又该作什么修改？最好能像合并所有工作表那段代码一样，不打开源工作簿就能实现合并就好了。

zhaogang1960

huazai688 发表于 2011-8-25 19:09
谢谢赵老师，已经满足了我的要求。新求助：如果不通过工作表序号，而是通过工作表名称（因为实际工作中每个 ...

看来你需要合并所有工作簿中共有的工作表，打开工作簿时计算出它们，你需要选择工作表1中组合框中的工作表名，单击按钮：


数据.rar (20.58 KB, 下载次数: 798)

2011-8-25 19:33 上传

点击文件名下载附件

huazai688

谢谢赵老师！已经基本达到我要的结果了，不过我在12楼提的问题中的最后一句【最好能像(5楼)合并所有工作表那段代码一样，不打开源工作簿就能实现合并就好了”】这个功能还没有实现，然后顺道能不能帮忙把代码修改成能实现“合并所有工作簿中共有的工作表到当前工作簿的同一张工作表上，而不是多张表”，谢谢！

zhaogang1960

huazai688 发表于 2011-8-26 08:20
谢谢赵老师！已经基本达到我要的结果了，不过我在12楼提的问题中的最后一句【最好能像(5楼)合并所有工作表那 ...

你的工作表数据不规范，不能完全使用ado方法，而13楼不打开取得工作表名又和打开工作簿open或getobject冲突(连续打开两个以上的工作簿会出错)，除非你的数据符合数据库管理规则(第一行是标题且不能含有空格等字符)

huazai688

谢谢！明白了，那就用13楼的代码，已经级满足要求了，只不过有点瑕疵罢了。

zhz3230

Sub zhz3230()
Dim Wk As Workbook, Sht As Worksheet, n As Integer, MyPath, MyName
Application.ScreenUpdating = False
Application.EnableEvents = False
n = 1
MyPath = ThisWorkbook.Path & "\"   '指定路径
MyName = Dir(MyPath & "\" & "*.xls")    '寻找第一项
For h = ThisWorkbook.Sheets.Count To 1 Step -1
If ThisWorkbook.Sheets(h).Name = "合并" Then
ThisWorkbook.Sheets(h).Delete
End If
Next
Set Nsh = ThisWorkbook.Sheets.Add(before:=Sheets(1))
Nsh.Name = "合并"
Do While MyName <> ""    '开始循环,从这之后Sheets(1)为汇总的工作薄的第一个工作表，改为Sheets(2)则为第二个工作表，如需要改需改这之后所有的Sheets(1)为相应的表
If MyName <> ThisWorkbook.Name Then
Set Wk = Workbooks.Open(MyPath & "\" & MyName)
Wk.Sheets(1).UsedRange = Wk.Sheets(1).UsedRange.Value
s = ThisWorkbook.Sheets("合并").UsedRange.Rows.Count
Wk.Sheets(1).Range(Wk.Sheets(1).Cells(1, 1), Wk.Sheets(1).Cells(Wk.Sheets(1).UsedRange.Rows.Count, Wk.Sheets(1).UsedRange.Columns.Count)).Copy ThisWorkbook.Sheets("合并").Cells(s + 3, 1)
Wk.Close False
End If
MyName = Dir
Loop
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

huazai688

谢谢17楼的代码，代码与我要求的思路相符，只是上述代码是默认合并代码为“sheet1"的工作表，若想合并其他工作表名时不知应对代码作何修改？我试着将上述代码中倒数第8段的代码：【Wk.Sheets(1).Range(Wk.Sheets(1).Cells(1, 1), Wk.Sheets(1).Cells(Wk.Sheets(1).UsedRange.Rows.Count, Wk.Sheets(1).UsedRange.Columns.Count)).Copy ThisWorkbook.Sheets("合并").Cells(s + 3, 1)
】中的Wk.Sheets(1).全改成对应的Wk.Sheets(2).或Wk.Sheets(3).，结果发现有的数据行会丢失（猜想可能是因为第一个工作表被第二个同名工作表合并时覆盖掉引起的），但不知道真正原因出在哪里，另外，现实工作中许多工作表名都会改成汉字，不像Sheet(1)等有规律，这时又如何修改代码，请17楼楼主帮忙完善一下，谢谢！

zhz3230

经测试可以
可以查找Wk.Sheets(1)全部替换为Wk.Sheets(2)
这样可以汇总第二个的工作表
注意是排第二的工作表，不是名字“Sheet2”的工作表

chenmeidi

Sub combo()
Dim Wk As Workbook, Sht As Worksheet, n As Integer, MyPath, MyName, t%
t = Val(InputBox("请选择工作表序号", , 1))
If t = 0 Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sh In Sheets
    If sh.Name <> ActiveSheet.Name Then sh.Delete
Next
n = 1
MyPath = ThisWorkbook.Path & "\"   '指定路径
MyName = Dir(MyPath & "\" & "*.xls")    '寻找第一项
Do While MyName <> ""    '开始循环
If MyName <> ThisWorkbook.Name Then
Set Wk = Workbooks.Open(MyPath & "\" & MyName)
Wk.Sheets(t).Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) '此处只插个第一个sheet
With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
.Name = Mid(MyName, 1, Len(MyName) - 4) '重新命名sheet
.UsedRange.Value = .UsedRange.Value
End With
Wk.Close False
End If
MyName = Dir    '查找下一个
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
这个代码，正是我需要的了，只不过有要合并的工作簿一般都是加密锁定的，运行不了，如果要一个个解密，要耗费很多时间，请高手能指点，帮忙修改，我是菜鸟，才开始蹒跚学步。