Zusammenführen von Daten aus verschiedenen Arbeitsmappe in bestimmten Blatt von Main-Arbeitsmappe

Question

Ich möchte einen Arbeitsblattinhalt namens "Task-Tracking" aus 3 verschiedenen Arbeitsmappen mit den Namen Sub WB1, Sub WB2 und Sub WB3 in einzelne Arbeitsmappen Aufgabe Arbeitsblatt zusammenführen. Bitte helfen Sie.

Es gibt 4 Arbeitsmappen mit insgesamt 12 Arbeitsblättern.

• Haupt Arbeitsmappe
• Sub WB1
• Sub WB2
• Sub WB3

Ich möchte die Daten von "Task Tracking" (Arbeitsblatt Name) von Sub WB1, Sub WB2 fusionieren und Sub WB3 in Main Workbook mit einem Consolidate-Button in der Hauptarbeitsmappe.

Ich habe den folgenden Code verwendet, den ich von einer Referenz bekommen habe, aber ich bekomme Runtime Error: 1004. Bitte helfen.

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() Verfahren akzeptieren keine solche FileFilter Syntax wie "Sub WB1.xlsm, Sub WB2.xlsm, Sub WB3.xlsm"

, wenn der Benutzer wollen nur, um Dateien mit bestimmten Namen, dann müssen Sie

ein Benutzerformular verwenden

Sie zum Beispiel handeln könnte wie folgt aussehen:

• Änderung:

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

  zu:

  FName = GetFName() 
  

• die Function folgende hinzufügen (vielleicht im selben Modul als Subs ein)

  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 
  

• ein UserForm zu Ihrem VBA-Projekt hinzufügen und benennen Sie es nach "ListFiles_UF" (Sie können einen beliebigen anderen gültigen Namen auswählen, aber im gesamten Code konsistent sein)

• Ort eines ListBox Kontrolle (durch nach „ListBox1“ genannt Standard) und eine Befehlssteuerung (standardmäßig den Namen nach „CommandButton1“) in der „ListFiles_UF“ Userform

• setzen Sie diesen Code in „ListFiles_UF“ Codebereich

  Private Sub CommandButton1_Click() 
      Me.Hide 
  End Sub