将来自不同工作簿的数据合并到主工作簿的特定工作表

Question

我想从3个名为Sub WB1，Sub WB2和Sub WB3的不同工作簿中将名为“任务跟踪”的工作表内容合并到单个主工作簿任务跟踪工作表中。请帮忙。

共有4个工作簿，每个工作簿共12个工作表。

• 主簿
• 子WB1
• 子WB2
• 子WB3

我想从小组WB1合并来自 “任务跟踪”（工作表名）的数据，分WB2并使用主工作簿中的Consolidate按钮将Sub WB3转换为主工作簿。

我用下面的代码，我从一些参考，但我得到运行时错误：1004请帮助。作为 "Sub WB1.xlsm, Sub WB2.xlsm, Sub WB3.xlsm"

，如果你想给用户给定的名称来选择文件，只有这样，你必须使用一个用户窗体

例如

Sub MergeSpecificWorkbooks() 

    Dim MyPath As String 
    Dim SourceRcount As Long, FNum As Long 
    Dim mybook As Workbook, BaseWks As Worksheet 
    Dim sourceRange As Range, destrange As Range 
    Dim rnum As Long, CalcMode As Long 
    Dim SaveDriveDir As String 
    Dim FName As Variant 


    'Change ScreenUpdating, Calculation and EnableEvents 
    With Application 
     CalcMode = .Calculation 
     .Calculation = xlCalculationManual 
     .ScreenUpdating = False 
     .EnableEvents = False 
    End With 

     'SaveDriveDir = CurDir 
     'ChDirNet "D:\DD_Task1\" 

     path = "D:\DD_Task1\" 

     'FName = Application.GetOpenFilename("Sub WB1.xls, Sub WB2.xls, Sub WB3.xls", MultiSelect:=True) 

    FName = Application.GetOpenFilename(filefilter:="Sub WB1.xlsm, Sub WB2.xlsm, Sub WB3.xlsm", _ 
    MultiSelect:=True) 

    If IsArray(FName) Then 
     'Add a new workbook with one sheet 
     'Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 
     Set BaseWks = Worksheets.Add 
     BaseWks.Name = "Master" 
     rnum = 2 

     'Loop through all files in the array(myFiles) 
     For FNum = LBound(FName) To UBound(FName) 
      Set mybook = Nothing 
      On Error Resume Next 
      Set mybook = Workbooks.Open(FName(FNum)) 
      On Error GoTo 0 
      If Not mybook Is Nothing Then 
       On Error Resume Next 
       With mybook.Worksheets("H-POD") 
        .Unprotect 
        LC = .Cells(.Rows.Count, "C").End(xlUp).Row 
        Set sourceRange = .Range("B10:M" & LC) 
       End With 
       If Err.Number > 0 Then 
        Err.Clear 
        Set sourceRange = Nothing 
       Else 
        'if SourceRange use all columns then skip this file 
        If sourceRange.Columns.Count >= BaseWks.Columns.Count Then 
         Set sourceRange = Nothing 
        End If 
       End If 
       On Error GoTo 0 
       If Not sourceRange Is Nothing Then 
        SourceRcount = sourceRange.Rows.Count 
        If rnum + SourceRcount >= BaseWks.Rows.Count Then 
         MsgBox "Sorry there are not enough rows in the sheet" 
         BaseWks.Columns.AutoFit 
         mybook.Close savechanges:=False 
         GoTo ExitTheSub 
        Else 
         'Copy the file name in column A 
         With sourceRange 
          BaseWks.Cells(rnum, "A"). _ 
          Resize(.Rows.Count).Value = FName(FNum) 
         End With 
         'Set the destrange 
         Set destrange = BaseWks.Range("B" & rnum) 
         'we copy the values from the sourceRange to the destrange 
         With sourceRange 
          Set destrange = destrange. _ 
          Resize(.Rows.Count, .Columns.Count) 
         End With 
         destrange.Value = sourceRange.Value 
         rnum = rnum + SourceRcount 
        End If 
       End If 
       mybook.Close savechanges:=False 
      End If 
     Next FNum 
     BaseWks.Columns.AutoFit 
    End If 
ExitTheSub: 

    'Restore ScreenUpdating, Calculation and EnableEvents 
    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
     .Calculation = CalcMode 
    End With 

    ' ChDirNet SaveDriveDir 

End Sub 

Answer 1

GetOpenFilename()方法不接受这样的FileFilter语法，可以采取以下措施：

• 更改：

  FName = Application.GetOpenFilename("Sub WB1.xls, Sub WB2.xls, Sub WB3.xls", MultiSelect:=True) 
  

  到：

  FName = GetFName() 
  

• 添加以下Function

  Function GetFName() As Variant 
      Dim iList As Long 
      Dim selectedFiles As String 
  
      With ListFiles_UF 
       With .ListBox1 
        .MultiSelect = fmMultiSelectMulti 
        .List = Array("Sub WB1.xlsm", "Sub WB2.xlsm", "Sub WB3.xlsm") 
       End With 
       .Show 
       With .ListBox1 
        If .ListIndex > 0 Then 
         For iList = 0 To .ListCount - 1 
          If .Selected(iList) Then selectedFiles = selectedFiles & .List(iList) & "|" 
         Next 
         GetFName = Split(Left(selectedFiles, Len(selectedFiles) - 1), "|") 
        End If 
       End With 
      End With 
  End Function 
  

• （也许是同一模块作为子的一个中）添加UserForm到您的VBA项目，并给它命名“ListFiles_UF”（您可以选择任何其他有效的名称，但必须与所有代码一致）

• 地方ListBox控制（由后“ListBox1的”名为default）在“ListFiles_UF”用户窗体

• 把这段代码为“ListFiles_UF”代码窗格

  和命令控制（通过“CommandButton1的”命名的默认值）

  Private Sub CommandButton1_Click() 
      Me.Hide 
  End Sub