將來自不同工作簿的數據合併到主工作簿的特定工作表

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