Kopieren Sie eine Reihe von Daten automatisch aus mehreren Excel-Dateien, indem Sie Dateien

Question

Ich versuche, ein Makro zu erstellen, das automatisch einige Daten aus mehreren Dateien über einen Bereich von Zellen kopiert, indem Sie die Excel-Dateien, die ich kopieren möchte. Ich habe derzeit etwas gemacht, aber es ist weit davon entfernt, zu effizient zu sein, weil ich Dateien immer in einem bestimmten Pfad speichern muss oder manchmal manuell den Zellbereich in einer Arbeitsmappe kopieren muss. Ich möchte die Arbeitsmappen auswählen und in der Lage sein, über eine vorhandene Arbeitsmappe zu speichern, da die Header einige Verweise haben können, und manchmal haben Dateien geschützte VBA-Projekte. Mein Code rechts unten kopiert eine Zeile aus dem ersten Arbeitsblatt und kopiert auch einen Bereich von Zellen aus dem zweiten Arbeitsblatt aus den Dateien, die in einem angegebenen Ordner geöffnet sind, und speichert diese Zellen dann in der Datei, in der sich der Code befindet.

  Sub LoopThroughDirectory() 
      On Error Resume Next 
      Dim MyFile As String 
      Dim erow 
      Dim erowc 
      Dim Filepath As String 
      Filepath = "C:\Users\noStress\Desktop\Workbook test\Destinatia mea\" 
      MyFile = Dir(Filepath) 


      Dim Matrice() As Variant 
      Dim Dim1, Dim2 As Long 

      Application.ScreenUpdating = False 
      Application.DisplayAlerts = False 

      Do While Len(MyFile) > 0 
       If MyFile = "Transport_data.xlsm" Then 
       Exit Sub 
       End If 

       Workbooks.Open (Filepath & MyFile) 
       Worksheets(1).Activate 
       Range("A2:M2").Copy 
        Worksheets(2).Activate 
        Dim1 = Range("A2", Range("A1").End(xlDown)).Cells.Count - 1 
        Dim2 = Range("A1", Range("A1").End(xlToRight)).Cells.Count - 1 

       ReDim Matrice(0 To Dim1, 0 To Dim2) 
       For Dim1 = LBound(Matrice, 1) To UBound(Matrice, 1) 
        For Dim2 = LBound(Matrice, 2) To UBound(Matrice, 2) 

          Matrice(Dim1, Dim2) = Range("A2").Offset(Dim1, Dim2).Value 

        Next Dim2 
       Next Dim1 
       ActiveWorkbook.Close 

       Worksheets(2).Activate 
       erowc = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row 
       ThisWorkbook.Worksheets(2).Range(Cells(erowc, 1), Cells(Dim1 + erowc - 1, Dim2)).Value = Matrice 

       Worksheets(1).Activate 
       erow = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row 
       ActiveSheet.Paste Destination:=Worksheets(1).Range(Cells(erow, 1), Cells(erow, 14)) 

        MyFile = Dir 


      Loop 



      End Sub 

Answer 1

Kommentare zu Ihrem Code

Application.DisplayAlerts = False bedeuten, dass der Benutzer keine Warnungen nicht sehen. Aus meiner Sicht ist das gefährlich. Ich verwende diese Aussage so:

Application.DisplayAlerts = False 
Delete worksheet 
Application.DisplayAlerts = True 

Das heißt, ich Ausschreibungen für eine einzelne Anweisung ausschalten. Ich werde mit dem Benutzer gegebenenfalls überprüft haben, ob es in Ordnung ist, das Arbeitsblatt zu löschen.

---

If MyFile = "Transport_data.xlsm" Then 
    Exit Sub 
End If 

Ich gehe davon aus Transport_data.xlsm die Arbeitsmappe ist das Makro enthält. In der Regel gibt Dir Dateien in der Reihenfolge zurück, die erstellt wurde, sodass alle Dateien, die nach Transport_data.xlsm erstellt wurden, nicht verarbeitet werden. Sie wollen so etwas wie:

If MyFile <> "Transport_data.xlsm" Then 
    Process file 
End If 

Es ist erwähnenswert, dass ThisWorkbook.Name den Namen der Arbeitsmappe gibt das Makro anhält, der ausgeführt wird. So würde die folgenden noch funktionieren, wenn Sie den Namen der Arbeitsmappe ändern:

If MyFile <> ThisWorkbook.Name Then 
    Process file 
End If 

---

Worksheets(N) ist das N-te Arbeitsblatt entlang der Tab. Wenn der Benutzer die Reihenfolge der Arbeitsblätter ändert, ändern sich die Arbeitsblattnummern und Sie erhalten möglicherweise nicht das erwartete Arbeitsblatt.

immer ein Arbeitsblatt mit Namen identifizieren: Worksheets("xxxxx")

Worksheets(N)Activate langsam und sollte vermieden werden.

Im Folgenden aktivieren Sie Worksheets(2) dann die vollständig qualifizieren Arbeitsblatt, das Sie in der Nach Aussage wollen:

Worksheets(2).Activate 
erowc = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row 

Sie die Activate

---

Sie verwenden

`ThisWorkbook.Worksheets(2).Range(Cells(erowc, 1), Cells(Dim1 + erowc - 1, Dim2)).Value = Matrice` 

nicht brauchen

zu d Eigenladung in den Zielbereich, aber Laden Matrice aus dem Quellbereich Zelle für Zelle. Sie können Matrice auf die gleiche Weise laden.

Dim Matrice As Variant 

Matrice = SourceRange.Value   ' This will size Matrice as required 
DestinationRange.Value = Matrice 

Ihre Anforderung

Sie wollen Daten aus mehreren Arbeitsmappen extrahieren nicht alle im gleichen Ordner gespeichert. Sie gehen davon aus, dass das von Ihnen benötigte Arbeitsblatt das erste Arbeitsblatt ist. Ihr Makro kopiert das gesamte Arbeitsblatt, aber Ihr Text deutet an, dass Sie selektiver sein möchten. Da Sie den Prozess automatisieren möchten, nehme ich an, dass es sich um einen Vorgang handelt, der sich in Intervallen wiederholt.

Ich bin vielleicht voreilige Schlüsse, aber das klingt wie eine Anforderung eines meiner Kunden. Sie erhielten mehrere Arbeitsmappen aus ihren Quellen, benötigten jedoch nur ausgewählte Informationen für ihre Verwaltungszusammenfassung. Sie führten die Konsolidierung manuell durch, was zeitraubend und fehleranfällig war.Wenn Ihre Anforderung der ihren entspricht, möchten Sie nicht, dass der Benutzer Dateien auswählt. Sie möchten den Prozess vollständig automatisieren. Ich habe nicht mehr den Code, den ich für diesen Client erstellt habe, aber ich habe eine einfache Version aus dem Speicher erstellt.

Ich habe eine Arbeitsmappe mit einem Arbeitsblatt mit dem Namen "Anweisungen" erstellt. Sie hatten mehrere solcher Arbeitsblätter, weil sie mehrere Konsolidierungen hatten. Aber man ist genug, um das Prinzip zu zeigen. Das Arbeitsblatt hat mehrere Zeilen. Jede Zeile gibt das Kopieren eines Bereichs von einer Arbeitsmappe in eine andere an. Die Säulen sind:

Source   Folder 
range   Workbook name 
       Worksheet name 
       Left column  \ 
       Top row   | Source range 
       Right column  | 
       Bottom row  /

Destination Folder 
range   Workbook name 
       Worksheet name 
       Top left destination cell 

Dies ist ein Bild von meinen Testdatum:

Hinweis: Diese Daten sind so konzipiert, um das Makro zu testen; es ist keine besonders vernünftige Menge von Anweisungen.

In dem System, das ich für den Client und das einfache Makro erstellt habe, das ich für Sie erstellt habe, ist Folder eine feste Zeichenfolge. Zum Beispiel: "C: \ Benutzer \ noStress \ Desktop \ Arbeitsmappe test \ Destinatia mea" oder "C: \ Benutzer \ ajdal \ Desktop \ Arbeitsmappen \ CopyRanges". Der Ordnername muss in der ersten Anweisungszeile angegeben werden. Es muss nur in nachfolgenden Zeilen angegeben werden, wenn es sich ändert.

In dem Makro, das ich für Sie erstellt habe, ist der Name des Arbeitsbuchs festgelegt. Zum Beispiel: "A.xlsx" oder "B.xlsx". Im System meines Kunden ist es eine Vorlage, zum Beispiel: "Branch A * .xlsx". Das Makro würde die neueste Datei aus dem Ordner auswählen, der dieser Vorlage entspricht.

In beiden Systemen ist der Name des Arbeitsblatts festgelegt.

Hinweis: Wenn ein neuer Ordner angegeben wird, sind ein neuer Arbeitsbuchname und ein neuer Arbeitsblattname erforderlich. Wenn ein neuer Arbeitsmappenname angegeben wird, ist ein neuer Arbeitsblattname erforderlich.

Werte sind immer erforderlich in Left, Top, Rght und Bot. Die Sequenz ist so gewählt, dass sie wie ein Bereich aussieht. Der Vorteil, diese als separate Spalten (anstatt beispielsweise "A1: D8") zu haben, besteht darin, dass Wörter wie "Last" leicht berücksichtigt werden können, so dass "A | 1 | Last | Last" ein ganzes Arbeitsblatt angibt und "A | Last | Last | Last" die gesamte letzte Zeile. Diese Funktionalität ist im folgenden Makro nicht enthalten.

Die Regeln für den Zielordner, die Arbeitsmappe und das Arbeitsblatt gelten für die Quelle.

Nur die obere linke Zelle wird für das Ziel benötigt. Ich habe Code eingefügt, um "D" oder "A" als das Ziel zuzulassen, das von der vorherigen Kopie oder gegenüber der vorherigen Kopie abweicht.

Wenn ein Wert innerhalb einer Anweisungszeile fehlt oder falsch ist, wird die Zelle Rose gefärbt und die Zeile wird ignoriert. Das Makro fährt mit der nächsten Reihe fort, so dass viele der Anweisungen in einem Durchgang getestet werden können. Zum Beispiel:

Das Makro wahrscheinlich zu viel Validierung hat und nicht genug Tests. Für den Kunden erstellte nichttechnisches Personal die Anweisungsarbeitsblätter. Wenn sie einen Arbeitsmappen- oder Arbeitsblattnamen falsch geschrieben haben, konnte das Makro nicht nur beim Öffnen der Arbeitsmappe oder beim Zugriff auf Arbeitsblätter anhalten, sodass alles überprüft wurde. Ich habe diese Validierung eingeschlossen, aber nicht für jeden möglichen Benutzerfehler getestet. Ich schließe immer Debug.Assert False am Anfang jedes Pfades durch meine Makros ein. Wenn während des Testens ein Pfad ausgeführt wird, kommentiere ich die Debug.Assert False aus. Alle, die am Ende des Tests unkommentiert bleiben, zeigen entweder an, dass meine Tests unzureichend waren oder dass mein Design fehlerhaft war und der Pfad nicht erreicht werden kann. Hier zeigen die Fehlerzustände an, die ich nicht getestet habe.

Hinweis: Ich habe SourceRange.Copy Destination:=TopLeftCell verwendet, um Daten zu kopieren. Dies hat den Vorteil, dass die Formatierung kopiert wird, hat aber den Nachteil, dass auch Formeln kopiert werden. Wenn dies nicht akzeptabel ist, kann das Kopieren über ein Variant-Array besser sein.

Wenn diese Funktionalität klingt interessant, haben ein Spiel mit dem Makro.

Option Explicit 

    Const ClrError As Long = 13408767 ' Rose = RGB(255, 153, 204) 
    Const ClrSrc As Long = 10092543  ' Light yellow = RGB(255, 255, 153) 
    Const ClrDest As Long = 16777164 ' Light turquoise - RGB(204, 255, 255) 

    Const ColInstSrcFld As Long = 1 
    Const ColInstSrcWbk As Long = 2 
    Const ColInstSrcWsht As Long = 3 
    Const ColInstSrcColLeft As Long = 4 
    Const ColInstSrcRowTop As Long = 5 
    Const ColInstSrcColRight As Long = 6 
    Const ColInstSrcRowBot As Long = 7 
    Const ColInstDestFld As Long = 8 
    Const ColInstDestWbk As Long = 9 
    Const ColInstDestWsht As Long = 10 
    Const ColInstDestRng As Long = 11 
    Const ColsSrc As String = "A:G"  ' \ Used for colouring columns 
    Const ColsDest As String = "H:K" '/
Sub CopyRanges() 

    Dim ColDest As Long 
    Dim ColSrcLeft As Long 
    Dim ColSrcRight As Long 
    Dim DestFldStr As String 
    Dim DestWbkStr As String 
    Dim DestWbkChanged As Boolean 
    Dim DestWshtStr As String 
    Dim DestRngStr As String 
    Dim ErrorOnRow As Boolean 
    Dim NumColsRngSrc As Long 
    Dim NumRowsRngSrc As Long 
    Dim RngDest As Range 
    Dim RngSrc As Range 
    Dim RowDest As Long 
    Dim RowInstCrnt As Long 
    Dim RowInstLast As Long 
    Dim RowSrcBot As Long 
    Dim RowSrcTop As Long 
    Dim SrcFldStr As String 
    Dim SrcWbkStr As String 
    Dim SrcWshtStr As String 
    Dim WbkDest As Workbook 
    Dim WbkSrc As Workbook 
    Dim WshtDest As Worksheet 
    Dim WshtInst As Worksheet 
    Dim WshtSrc As Worksheet 

    ' Note the initial values for variables are: 
    ' 0 for Long 
    ' "" for String 
    ' Nothing for Object (for example: workbook, worksheet, range) 

    Application.ScreenUpdating = False 

    Set WshtInst = Worksheets("Instructions") 

    With WshtInst 
    ' Restore background colour of source and destination columns 
    ' to clear and error recorded by last run. 
    .Columns(ColsSrc).Interior.Color = ClrSrc 
    .Columns(ColsDest).Interior.Color = ClrDest 

    ' Find last row of instructions 
    RowInstLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row 
    End With 

    For RowInstCrnt = 3 To RowInstLast 

    With WshtInst 
     ErrorOnRow = False 

     ' Validate source columns of instructions 
     If .Cells(RowInstCrnt, ColInstSrcFld).Value <> "" Then 
     ' New source folder; must be new workbook and worksheet 
     'Debug.Assert False 
     If .Cells(RowInstCrnt, ColInstSrcWbk).Value = "" Then 
      Debug.Assert False 
      .Cells(RowInstCrnt, ColInstSrcWbk).Interior.Color = ClrError ' Record faulty value 
      ErrorOnRow = True 
     End If 
     If .Cells(RowInstCrnt, ColInstSrcWsht).Value = "" Then 
      Debug.Assert False 
      .Cells(RowInstCrnt, ColInstSrcWsht).Interior.Color = ClrError ' Record faulty value 
      ErrorOnRow = True 
     End If 
     ElseIf .Cells(RowInstCrnt, ColInstSrcWbk).Value <> "" Then 
     ' New source workbook; must be new worksheet 
     'Debug.Assert False 
     If .Cells(RowInstCrnt, ColInstSrcWsht).Value = "" Then 
      'Debug.Assert False 
      .Cells(RowInstCrnt, ColInstSrcWsht).Interior.Color = ClrError ' Record faulty value 
      ErrorOnRow = True 
     End If 
     End If 

     ' Source range must always be specified in full 

     ' Top row must be non-empty, numeric and a valid row number 
     If .Cells(RowInstCrnt, ColInstSrcRowTop).Value = "" Then 
     'Debug.Assert False 
     .Cells(RowInstCrnt, ColInstSrcRowTop).Interior.Color = ClrError ' Record faulty value 
     ErrorOnRow = True 
     ElseIf Not IsNumeric(.Cells(RowInstCrnt, ColInstSrcRowTop).Value) Then 
     Debug.Assert False 
     .Cells(RowInstCrnt, ColInstSrcRowTop).Interior.Color = ClrError ' Record faulty value 
     ErrorOnRow = True 
     Else 
     RowSrcTop = .Cells(RowInstCrnt, ColInstSrcRowTop).Value 
     If RowSrcTop < 1 Or RowSrcTop > Rows.Count Then 
      .Cells(RowInstCrnt, ColInstSrcRowTop).Interior.Color = ClrError ' Record faulty value 
      ErrorOnRow = True 
     End If 
     End If 

     ' Left column must be non-empty and a valid column code 
     If .Cells(RowInstCrnt, ColInstSrcColLeft).Value = "" Then 
     Debug.Assert False 
     .Cells(RowInstCrnt, ColInstSrcColLeft).Interior.Color = ClrError ' Record faulty value 
     ErrorOnRow = True 
     Else 
     ColSrcLeft = ColNum(.Cells(RowInstCrnt, ColInstSrcColLeft).Value) 
     If ColSrcLeft = 0 Then 
      Debug.Assert False 
      .Cells(RowInstCrnt, ColInstSrcColLeft).Interior.Color = ClrError ' Record faulty value 
     End If 
     End If 

     ' Bottom row must be non-empty, numeric and a valid row number greater or equal to top row 
     If .Cells(RowInstCrnt, ColInstSrcRowBot).Value = "" Then 
     Debug.Assert False 
     .Cells(RowInstCrnt, ColInstSrcRowBot).Interior.Color = ClrError ' Record faulty value 
     ErrorOnRow = True 
     ElseIf Not IsNumeric(.Cells(RowInstCrnt, ColInstSrcRowBot).Value) Then 
     Debug.Assert False 
     .Cells(RowInstCrnt, ColInstSrcRowBot).Interior.Color = ClrError ' Record faulty value 
     ErrorOnRow = True 
     Else 
     RowSrcBot = .Cells(RowInstCrnt, ColInstSrcRowBot).Value 
     If RowSrcBot < 1 Or RowSrcBot > Rows.Count Or RowSrcTop > RowSrcBot Then 
      .Cells(RowInstCrnt, ColInstSrcRowTop).Interior.Color = ClrError ' Record faulty value 
      ErrorOnRow = True 
     End If 
     End If 

     ' right column must be non-empty and a valid column code greater or equal to left column 
     If .Cells(RowInstCrnt, ColInstSrcColRight).Value = "" Then 
     Debug.Assert False 
     .Cells(RowInstCrnt, ColInstSrcColRight).Interior.Color = ClrError ' Record faulty value 
     ErrorOnRow = True 
     Else 
     ColSrcRight = ColNum(.Cells(RowInstCrnt, ColInstSrcColRight).Value) 
     If ColSrcRight = 0 Or ColSrcLeft > ColSrcRight Then 
      Debug.Assert False 
      .Cells(RowInstCrnt, ColInstSrcColRight).Interior.Color = ClrError ' Record faulty value 
     End If 
     End If 

     ' If no error in source columns, load new values from instruction row to variables. 
     ' Check have value for every parameter. Check folder and workbook exist if specified 
     ' Close old workbook if appropriate. Open new workbook if appropriate 
     If Not ErrorOnRow Then 
     'Debug.Assert False 
     If .Cells(RowInstCrnt, ColInstSrcFld).Value <> "" Then 
      ' New source folder 
      'Debug.Assert False 
      SrcFldStr = .Cells(RowInstCrnt, ColInstSrcFld).Value 
      If Right$(SrcFldStr, 1) <> "\" Then 
      'Debug.Assert False 
      SrcFldStr = SrcFldStr & "\" 
      End If 
      If Not PathExists(SrcFldStr) Then 
      Debug.Assert False 
      .Cells(RowInstCrnt, ColInstSrcFld).Interior.Color = ClrError ' Record faulty value 
      SrcFldStr = "" 
      ErrorOnRow = True 
      End If 
     ElseIf SrcFldStr = "" Then 
      ' No source folder specified 
      Debug.Assert False 
      .Cells(RowInstCrnt, ColInstSrcFld).Interior.Color = ClrError ' Record faulty value 
      ErrorOnRow = True 
     End If 
     End If 
     If Not ErrorOnRow Then 
     'Debug.Assert False 
     If .Cells(RowInstCrnt, ColInstSrcWbk).Value <> "" Then 
      ' New source workbook; close old one if any 
      'Debug.Assert False 
      If Not WbkSrc Is Nothing Then 
      'Debug.Assert False 
      WbkSrc.Close SaveChanges:=False 
      Set WbkSrc = Nothing 
      End If 
      SrcWbkStr = .Cells(RowInstCrnt, ColInstSrcWbk).Value 
      If FileExists(SrcFldStr, SrcWbkStr) Then 
      'Debug.Assert False 
      Set WbkSrc = Workbooks.Open(FileName:=SrcFldStr & SrcWbkStr, _ 
             UpdateLinks:=True, ReadOnly:=True) 
      Else 
      'Debug.Assert False 
      .Cells(RowInstCrnt, ColInstSrcWbk).Interior.Color = ClrError ' Record faulty value 
      ErrorOnRow = True 
      End If 
     End If 
     End If 
     If Not ErrorOnRow Then 
     'Debug.Assert False 
     If .Cells(RowInstCrnt, ColInstSrcWsht).Value <> "" Then 
      'Debug.Assert False 
      SrcWshtStr = .Cells(RowInstCrnt, ColInstSrcWsht).Value 
      If WshtExists(WbkSrc, SrcWshtStr) Then 
      'Debug.Assert False 
      Set WshtSrc = WbkSrc.Worksheets(SrcWshtStr) 
      Else 
      'Debug.Assert False 
      .Cells(RowInstCrnt, ColInstSrcWsht).Interior.Color = ClrError ' Record faulty value 
      ErrorOnRow = True 
      End If 
     End If 
     End If 
     If Not ErrorOnRow Then 
     'Debug.Assert False 
     Set RngSrc = WshtSrc.Range(WshtSrc.Cells(RowSrcTop, ColSrcLeft), _ 
            WshtSrc.Cells(RowSrcBot, ColSrcRight)) 
     End If 

     ' Validate destination columns of instructions. 
     If .Cells(RowInstCrnt, ColInstDestFld).Value <> "" Then 
     ' New destination folder; must be new workbook, worksheet and range 
     'Debug.Assert False 
     If .Cells(RowInstCrnt, ColInstDestWbk).Value = "" Then 
      Debug.Assert False 
      .Cells(RowInstCrnt, ColInstDestWbk).Interior.Color = ClrError ' Record faulty value 
      ErrorOnRow = True 
     End If 
     If .Cells(RowInstCrnt, ColInstDestWsht).Value = "" Then 
      Debug.Assert False 
      .Cells(RowInstCrnt, ColInstDestWsht).Interior.Color = ClrError ' Record faulty value 
      ErrorOnRow = True 
     End If 
     If .Cells(RowInstCrnt, ColInstDestRng).Value = "" Then 
      Debug.Assert False 
      .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError ' Record faulty value 
      ErrorOnRow = True 
     End If 
     ElseIf .Cells(RowInstCrnt, ColInstDestWbk).Value <> "" Then 
     ' New destination workbook; must be new worksheet and range 
     'Debug.Assert False 
     If .Cells(RowInstCrnt, ColInstDestWsht).Value = "" Then 
      Debug.Assert False 
      .Cells(RowInstCrnt, ColInstDestWsht).Interior.Color = ClrError ' Record faulty value 
      ErrorOnRow = True 
     End If 
     If .Cells(RowInstCrnt, ColInstDestRng).Value = "" Then 
      Debug.Assert False 
      .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError ' Record faulty value 
      ErrorOnRow = True 
     End If 
     End If 
     If .Cells(RowInstCrnt, ColInstDestRng).Value = "" Then 
     ' Destination range must always be specified 
     Debug.Assert False 
     .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError ' Record faulty value 
     ErrorOnRow = True 
     End If 

     ' If no error in destination columns, load new values from instruction row to variables. 
     ' Check have value for every parameter. Check folder and workbook exist if specified 
     ' Close old workbook if appropriate. Open new workbook if appropriate 
     If Not ErrorOnRow Then 
     'Debug.Assert False 
     If .Cells(RowInstCrnt, ColInstDestFld).Value <> "" Then 
      ' New destination folder 
      'Debug.Assert False 
      DestFldStr = .Cells(RowInstCrnt, ColInstDestFld).Value 
      If Right$(DestFldStr, 1) <> "\" Then 
      DestFldStr = DestFldStr & "\" 
      End If 
      If Not PathExists(DestFldStr) Then 
      Debug.Assert False 
      .Cells(RowInstCrnt, ColInstDestFld).Interior.Color = ClrError ' Record faulty value 
      DestFldStr = "" 
      ErrorOnRow = True 
      End If 
     ElseIf DestFldStr = "" Then 
      ' No destination folder specified 
      Debug.Assert False 
      .Cells(RowInstCrnt, ColInstDestFld).Interior.Color = ClrError ' Record faulty value 
      ErrorOnRow = True 
     End If 
     End If 
     If Not ErrorOnRow Then 
     'Debug.Assert False 
     If .Cells(RowInstCrnt, ColInstDestWbk).Value <> "" Then 
      ' New destination workbook; close old one if any 
      'Debug.Assert False 
      If Not WbkDest Is Nothing Then 
      'Debug.Assert False 
      If DestWbkChanged Then 
       'Debug.Assert False 
       WbkDest.Close SaveChanges:=True 
       DestWbkChanged = False 
      Else 
       Debug.Assert False 
       WbkDest.Close SaveChanges:=False 
      End If 
      Set WbkDest = Nothing 
      End If 
      DestWbkStr = .Cells(RowInstCrnt, ColInstDestWbk).Value 
      If FileExists(DestFldStr, DestWbkStr) Then 
      'Debug.Assert False 
      Set WbkDest = Workbooks.Open(FileName:=DestFldStr & DestWbkStr, _ 
             UpdateLinks:=True, ReadOnly:=False) 
      DestWbkChanged = False 
      Else 
      'Debug.Assert False 
      .Cells(RowInstCrnt, ColInstDestWbk).Interior.Color = ClrError ' Record faulty value 
      ErrorOnRow = True 
      End If 
     Else 
      ' No new workbook. Check one remains open from previous instructions 
      If WbkDest Is Nothing Then 
      'Debug.Assert False 
      .Cells(RowInstCrnt, ColInstDestWbk).Interior.Color = ClrError ' Record faulty value 
      ErrorOnRow = True 
      End If 
     End If 
     End If 
     If Not ErrorOnRow Then 
     'Debug.Assert False 
     If .Cells(RowInstCrnt, ColInstDestWsht).Value <> "" Then 
      'Debug.Assert False 
      DestWshtStr = .Cells(RowInstCrnt, ColInstDestWsht).Value 
      If WshtExists(WbkDest, DestWshtStr) Then 
      'Debug.Assert False 
      Set WshtDest = WbkDest.Worksheets(DestWshtStr) 
      ' Clear source range and destination cell information saved from 
      ' previous instruction row and used in processing "destination cells" 
      ' A(cross) and D(own). 
      RowDest = 0 
      ColDest = 0 
      NumRowsRngSrc = 0 
      NumColsRngSrc = 0 
      Else 
      Debug.Assert False 
      .Cells(RowInstCrnt, ColInstDestWsht).Interior.Color = ClrError ' Record faulty value 
      ErrorOnRow = True 
      End If 
     End If 
     End If 
     If Not ErrorOnRow Then 
     'Debug.Assert False 
     Select Case UCase(.Cells(RowInstCrnt, ColInstDestRng).Value) 
      Case "D" ' Down from previous transfer 
      ' Should have RowDest, ColDest, NumRowsRngSrc and NumColsRngSrc from 
      ' last instruction row 
      'Debug.Assert False 
      If RowDest = 0 Or ColDest = 0 Or NumRowsRngSrc = 0 Or NumColsRngSrc = 0 Then 
       ' No appropriate previous instruction row 
       Debug.Assert False 
       .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError ' Record faulty value 
       ErrorOnRow = True 
      Else 
       'Debug.Assert False 
       ' Calculate new row from information saved from last 
       ' error-free instruction row. Column unchanged. 
       RowDest = RowDest + NumRowsRngSrc 
      End If 
      Case "A" ' Across from previous transfer 
      ' Should have RowDest, ColDest, NumRowsRngSrc and NumColsRngSrc from 
      ' last instruction row 
      'Debug.Assert False 
      If RowDest = 0 Or ColDest = 0 Or NumRowsRngSrc = 0 Or NumColsRngSrc = 0 Then 
       ' No appropriate previous instruction row 
       Debug.Assert False 
       .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError ' Record faulty value 
       ErrorOnRow = True 
      Else 
       'Debug.Assert False 
       ' Calculate new column from information saved from last 
       ' error-free instruction row. Row unchanged 
       ColDest = ColDest + NumColsRngSrc 
      End If 
      Case Else 
      'Debug.Assert False 
      DestRngStr = .Cells(RowInstCrnt, ColInstDestRng).Value 
      Err.Clear 
      On Error Resume Next 
      Set RngDest = WshtDest.Range(DestRngStr) 
      On Error GoTo 0 
      If Err <> 0 Then 
       Debug.Assert False 
       ' Faulty range 
       .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError ' Record faulty value 
       ErrorOnRow = True 
      Else 
       ' Convert destination to numbers 
       'Debug.Assert False 
       ColDest = RngDest.Column 
       RowDest = RngDest.Row 
      End If 
     End Select 
     End If 

    End With ' WshtInst 

    If Not ErrorOnRow Then 

     ' All parameters stored ready for actioning 

     RngSrc.Copy Destination:=WshtDest.Cells(RowDest, ColDest) 
     DestWbkChanged = True 
     ' Extract number of rows and columns from source range in case next 
     ' instruction has "destination cell" as A(cross) or D(own) 
     NumRowsRngSrc = RngSrc.Rows.Count 
     NumColsRngSrc = RngSrc.Columns.Count 

    End If 

    Next 

    If Not WbkSrc Is Nothing Then 
    'Debug.Assert False 
    WbkSrc.Close SaveChanges:=False 
    Set WbkSrc = Nothing 
    End If 

    If Not WbkDest Is Nothing Then 
    Debug.Assert False 
    If DestWbkChanged Then 
     Debug.Assert False 
     WbkSrc.Close SaveChanges:=True 
    Else 
     Debug.Assert False 
     WbkSrc.Close SaveChanges:=False 
    End If 
    Set WbkDest = Nothing 
    End If 

End Sub 
Public Function ColNum(ByVal ColCode As String) As Long 

    ' Checks ColCode is a valid column code for the version of Excel in use 
    ' If it is, it returns the equivalent column number. 
    ' If it is not, it returns 0. 

    ' Coded by Tony Dallimore 

    Dim ChrCrnt As String 
    Dim ColCodeUc As String: ColCodeUc = UCase(ColCode) 
    Dim Pos As Long 

    ColNum = 0 

    For Pos = 1 To Len(ColCodeUc) 
    ChrCrnt = Mid(ColCodeUc, Pos, 1) 
    If ChrCrnt < "A" Or ChrCrnt > "Z" Then 
     ColNum = 0 
     Exit Function 
    End If 
    ColNum = ColNum * 26 + Asc(ChrCrnt) - 64 
    Next 

    If ColNum < 1 Or ColNum > Columns.Count Then 
    ColNum = 0 
    End If 

End Function 
Public Function FileExists(ByVal PathName As String, ByVal FileName As String) As Boolean 

    ' Returns True if file exists. Assumes path already tested. 

    ' Coded by Tony Dallimore 
    ' Based on code written by iDevlop: http://stackoverflow.com/a/28237845/973283 

    If Right$(PathName, 1) <> "\" Then 
    PathName = PathName & "\" 
    End If 
    On Error Resume Next 
    FileExists = ((GetAttr(PathName & FileName) And vbDirectory) <> vbDirectory) 
    On Error GoTo 0 

End Function 
Public Function PathExists(ByVal PathName As String) As Boolean 

    ' Returns True if path exists 

    ' Coded by Tony Dallimore 
    ' Based on code written by iDevlop: http://stackoverflow.com/a/28237845/973283 

    On Error Resume Next 
    PathExists = ((GetAttr(PathName) And vbDirectory) = vbDirectory) 
    On Error GoTo 0 

End Function 
Public Function WshtExists(ByRef Wbk As Workbook, ByVal WshtName As String) 

    ' Returns True if Worksheet WshtName exists within 
    ' * if Wbk Is Nothing the workbook containing the macros 
    ' * else workbook Wbk 

    ' Coded by Tony Dallimore 

    Dim WbkLocal As Workbook 
    Dim Wsht As Worksheet 

    If Wbk Is Nothing Then 
    Set WbkLocal = ThisWorkbook 
    Else 
    Set WbkLocal = Wbk 
    End If 

    Err.Clear 
    On Error Resume Next 
    Set Wsht = WbkLocal.Worksheets(WshtName) 
    On Error GoTo 0 
    If Wsht Is Nothing Then 
    WshtExists = False 
    Else 
    WshtExists = True 
    End If 

End Function 

Answer 2

Ich hoffe, dass ich dieses Recht hätte ...

Sie mögen:

• dynamisch Dateien aus einem bestimmten Ordner
• kopieren Zellen aus den ausgewählten Dateien in 1 Blatt wählen und 2 zu Ihrem aktuellen Arbeitsbuch
• Speichern Sie die aktuelle Arbeitsmappe? (Ich habe nicht ganz verstanden, was Sie hier gemeint, damit ich diesen Teil weggelassen)

Mein Nehmen auf sie:

1. Erstellen einer Userform (ufCopy) mit einer Listbox (lstFile, 2 Spalten) und eine Befehlsschaltfläche (cmdCopy)
2. erstellen sie eine Befehlstaste auf Ihrem Blatt es
3. Check „Microsoft Scripting Runtime“ in Extras zu starten -> Referenzen zu vermeiden, Objekte erstellen
4. Kopieren sie diesen Code in das Userforms Quelle Code

Code:

Private Sub UserForm_Initialize() 

     Call GetFiles("C:\example\example") 'Enter your folder path here 

    End Sub 

    Private Sub GetFiles(strFile As String) 

     ' 
     'Populates Listbox with all Excel files in the chosen folder and subfolders 
     ' 

     Dim fso As Scripting.FileSystemObject 
     Dim fsoFolder As Scripting.Folder 
     Dim fsoSubfolder As Scripting.Folder 
     Dim fsoFile As Scripting.File 

     Set fso = New Scripting.FileSystemObject 
     Set fsoFolder = fso.GetFolder(strFile) 

     For Each fsoFile In fsoFolder.Files 

      If Left(fso.GetExtensionName(fsoFile.Path), 2) = "xl" Then 
       With Me.lstFiles 
        .AddItem 
        .List(.ListCount - 1, 0) = fsoFile.Name 
        .List(.ListCount - 1, 1) = fsoFile.Path 
       End With 
      End If 

     Next fsoFile 

     For Each fsoSubfolder In fsoFolder.SubFolders 

      Call GetFiles(fsoSubfolder.Path) 

     Next fsoSubfolder 

    End Sub 

    Private Sub cmdCopy_Click() 

     Dim Msg As String 
     Dim iCounter As Integer 
     Dim wbCur As Workbook 

     Application.ScreenUpdating = False 

     For iCounter = 0 To Me.lstFiles.ListCount - 1 

      If Me.lstFiles.Selected(iCounter) Then 

       Set wbCur = Workbooks.Open(Me.lstFiles.List(iCounter, 0) & Me.lstFiles.List(iCounter, 1)) 
       ' 
       'Copy from first sheet 
       ' 
       wbCur.Worksheets(1).Range("A2:M2").Copy Destination:=ThisWorkbook.Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) 
       ' 
       'Copy from second sheet 
       ' 
       With wbCur.Worksheets(2) 
        .Range("A1", .Range("A2").End(xlDown).End(xlToRight)).Copy Destination:=ThisWorkbook.Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) 
       End With 

       wbCur.Close savechanges:=False 

       End If 
     Next iCounter 

     Application.ScreenUpdating = True 
    End Sub 

Dies tut:

• Alle Excel-Dateien des ausgewählten Ordners und Unterordner in einem Multiselect Listbox
• Loops durch alle ausgewählten Arbeitsmappen und kopiert die Zellen zu diesem

habe ich nicht sehe den Zweck dieses Arrays, also habe ich es entfernt. Sie können den Code für das Kopieren nach Ihren Bedürfnissen frei anpassen.

Um die Userform, kopieren Sie diese in den Kodex für das Blatt mit Ihrer Befehlstaste zu starten:

Private Sub CommandButton1_Click() 

    ufCopy.Show 

End Sub 

Edit: dynamisch Ihren Ordnerpfad zu wählen, verwenden:

Private Sub UserForm_Initialize() 

Dim strFolder 
Dim fdFolder As FileDialog 

' Open the file dialog 
Set fdFolder = Application.FileDialog(msoFileDialogFolderPicker) 
fdFolder.AllowMultiSelect = False 
fdFolder.Show 

strFolder = fdFolder.SelectedItems(1) 

Call GetFiles(strFolder) 

End Sub 

Wenn Wenn Sie die Dateien aus verschiedenen Pfaden abrufen möchten, fügen Sie den obigen Code einfach zu einer Befehlsschaltfläche in Ihrem Benutzerformular hinzu, anstatt sie zu initialisieren. Auf diese Weise können Sie darauf klicken und mehrere Verzeichnisse hinzufügen.