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

huazai688

求代码：如何合并不同工作簿中的某一同名工作表？
如book1中有sheet1、sheet2、sheet3三个工作表
    book2中有sheet1、sheet2、sheet3、sheet4四个工作表
而我只想复制book1与book2同名三个表（sheet1、sheet2、sheet3）中的其中一个同名的工作表如sheet2；或想复制同名中的某二个同名工作表到当前工作簿，

jiminyanyan

多工作簿汇总搜索一下。或上个附件。。。

huazai688

先谢谢大家，现上传附件，想通过达到2种效果，上网搜了好多，只有搜到合并各工作簿的第一个工作表或所有工作表的，而我实际上只需要合并某一指定的同名工作表，所以才又在此发此类求助，麻烦大家了，谢谢！

半夜爬上你床

上个附件或者截图上来看看

zhaogang1960

短信收到，没有看懂，试试看吧：
Sub Macro1()
    Dim MyPath$, MyName$, sh As Worksheet, d As Object, r&
    Set d = CreateObject("scripting.dictionary")
    MyPath = ThisWorkbook.Path & "\"
    MyName = Dir(MyPath & "*.xls")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each sh In Sheets
        If sh.Name <> ActiveSheet.Name Then sh.Delete
    Next
    Do While MyName <> ""
        If MyName <> ThisWorkbook.Name Then
            With GetObject(MyPath & MyName)
                For Each sh In .Sheets
                    If IsSheetEmpty = IsEmpty(sh.UsedRange) Then
                        If Not d.Exists(sh.Name) Then
                            sh.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                            Set d(sh.Name) = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                        Else
                            With d(sh.Name)
                                r = .UsedRange.Row + .UsedRange.Rows.Count + 2
                                sh.UsedRange.Copy .Cells(r, 1)
                            End With
                        End If
                    End If
                Next
                .Close False
            End With
        End If
        MyName = Dir
    Loop
    Sheets(1).Activate
    Application.ScreenUpdating = True
End Sub

huazai688

谢谢赵老师！但上述代码是实现各工作簿中所有同名工作表的合并，我想要的是只合并其中某一特定同名工作表，比如我只想要做到各工作簿中工作表名称=sheet1（或者sheet2）的合并就行了，即达到上传附件中的《合并效果1》中的效果就行了，也就是说只需要把各工作簿中的同名为sheet1的工作表合并即可，而不合并sheet2、sheet3同名工作表。不知这样表述是否理解，谢谢！

jiminyanyan

huazai688 发表于 2011-8-25 17:24
谢谢赵老师！但上述代码是实现各工作簿中所有同名工作表的合并，我想要的是只合并其中某一特定同名工作表， ...

全部合并了不是也好么，你想要哪张就哪张。。。

huazai688

我上传的只是测试表，实际工作中每个工作簿中有很多张工作表，如果都合并的话，还要把不需要的删除，太麻烦了

huazai688

Sub combo()
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")    '寻找第一项
Do While MyName <> ""    '开始循环
If MyName <> ThisWorkbook.Name Then
Set Wk = Workbooks.Open(MyPath & "\" & MyName)
Wk.Sheets(1).Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) '此处只插个第一个sheet
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Mid(MyName, 1, Len(MyName) - 4) '重新命名sheet
'For Each Sht In Wk.Sheets '多个sheet
'Sht.Name = Format(n, "000″)
'n = n + 1
'Next
Wk.Close False
End If
MyName = Dir    '查找下一个
Loop
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

上述是合并各工作簿第一张表的代码，不知道哪位高手可以将其修改成我需要的复制指定工作表的代码？

huazai688

对了，合并工作表时最好是数值性粘贴方式，因为实际工作中需要合并的工作表存在公式和宏，如果是原格式带公式复制的话，不仅影响速度，又会造成跨工作表引用。