怎样有选择地合并工作簿？

leobu

有问题请教大家：现在有一个文件夹里含有数百张工作簿，每个工作簿含有一张工作表，并且每个工作簿名称与其内含的工作表名称相同。现需要合并这些工作簿（表）到一个工作簿里，我在网上下载了程序如下：
Sub CombineFiles()


    Dim path           As String
    Dim FileName       As String
    Dim LastCell       As Range
    Dim Wkb            As Workbook
    Dim WS             As Worksheet
    Dim ThisWB         As String


   Dim MyDir As String
    MyDir = ThisWorkbook.path & "\"
    'ChDriveLeft(MyDir, 1) 'find all the excel files
   'ChDir MyDir
    'Match =Dir$("")

    ThisWB = ThisWorkbook.Name
   Application.EnableEvents = False
   Application.ScreenUpdating = False
    path = MyDir
    FileName = Dir(path & "\*.xls", vbNormal)
    Do Until FileName = ""
       If FileName <> ThisWB Then
           Set Wkb = Workbooks.Open(FileName:=path & "\" & FileName)
           For Each WS In Wkb.Worksheets
               Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)
               If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
               Else
                   WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
               End If
           Next WS
           Wkb.Close False
       End If
       FileName = Dir()
    Loop
   Application.EnableEvents = True
   Application.ScreenUpdating = True

    Set Wkb = Nothing
    Set LastCell = Nothing

End Sub

        具体做法是：在原文件夹里新建一份工作簿，并且插入模块运行以上程序后，可将原文件夹中的原有工作簿统一合并到新建工作簿中。但是我现在需要有选择性地合并一部分工作簿：如图所示，在新建工作簿的sheet1工作表的e列给出需要合并的工作簿名称，需要根据这份名单将所需要的工作簿合并进来。当然，其中有些需要合并工作簿可能不存在，例如原文件夹中并没有第“15”号和第“99”号工作簿，这时需要跳过它们，继续寻找原文件夹中存在的，并且在合并名单中的工作簿继续合并直至完成。恳请哪位高手帮我看看如何修改以上程序？

chxw68

修改了一下代码，由于我的系统是2003版本的，没有测试。

1. Sub 合并工作簿()
   
2. 
   
3. 
   
4.     Dim path           As String
   
5.     Dim FileName       As String
   
6.     Dim LastCell       As Range
   
7.     Dim Wkb            As Workbook
   
8.     Dim WS             As Worksheet
   
9.     Dim ThisWB         As String
   
10.    
    
11.   
    
12.    Dim MyDir As String
    
13.     MyDir = ThisWorkbook.path & ""
    
14.     'ChDriveLeft(MyDir, 1) 'find all the excel files
    
15.    'ChDir MyDir
    
16.     'Match =Dir$("")
    
17.    
    
18.    ThisWB = ThisWorkbook.Name
    
19.    Application.EnableEvents = False
    
20.    Application.ScreenUpdating = False
    
21.     With Worksheets("sheet1")
    
22.       r = .Cells(.Rows.Count, 5).End(xlUp).Row
    
23.       arr = .Range("e2:e" & r)
    
24.     End With
    
25.     FileName = Dir(MyDir & "\*.xls", vbNormal)
    
26.     For i = 1 To UBound(arr)
    
27.       If Dir(MyDir & arr(i, 1) & ".xlsx") <> "" Then
    
28.            Set Wkb = Workbooks.Open(FileName:=MyDir & "" & arr(i, 1) & ".xlsx")
    
29.            For Each WS In Wkb.Worksheets
    
30.                Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)
    
31.                If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
    
32.                Else
    
33.                    WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
34.                End If
    
35.            Next WS
    
36.            Wkb.Close False
    
37.        End If
    
38.     Next
    
39.    Application.EnableEvents = True
    
40.    Application.ScreenUpdating = True
    
41.    
    
42.     Set Wkb = Nothing
    
43.     Set LastCell = Nothing
    
44. End Sub

复制代码

leobu

感谢chxw68的热情帮助，给出的这段修改程序确实能在原先的范例文件里顺利运行。
但是有一点我没有说清楚，我要合并的工作簿都是excel2003版本的，并且有些工作簿的命名是采用类似"000002"这种格式，在这种情况下，以上修改的程序就不能运行了。问题没表达清楚就来提问，这完全怪我。现在我把示例文件夹重新只做了一下，麻烦高手有空的话，再帮我看看，谢谢。
注：新的示例文件中，模块1是原始程序，模块2是chxw68给出的修改程序。