Office: (Office 2013) Per VBA auf Dateien im Ordner zugreifen

Hallo,

ich habe mehrere Dateien in einem Ordner und möchte das erste Tabellenblatt jeder Datei in ein anderes Dokument zusammenführen.

Habe ein Code geschrieben, bei dem mir immer eine bestimmte Datei geöffnet und das Blatt rauskopiert wird. Jetzt sind aber immer unterschiedlich viele Dateien und mit unterschiedlichen Namen in dem Ordner und es sollen aus jeder Datei das erste Blatt rauskopiert werden.

Wie müsste ich den Code anpassen?

Danke schon mal im voraus!

Sub Daten_ziehen()

Application.ScreenUpdating = False
Application.EnableEvents = False

Workbooks.Open "C:\...\test\Bauteil_Checkliste.xlsm"
Workbooks("Bauteil_Checkliste.xlsm").Activate
Sheets(1).Select
Sheets(1).Copy After:=Workbooks("Baugruppen_Checkliste_2015.xlsm"). _
Sheets(1)

Workbooks("Bauteil_Checkliste.xlsm").Close


End Sub

 

Hallo,

dafür gibt es in VBA die Funktion "Dir([Pfad\Dateimaske],[Dateiattribute])", um in Verzeichnissen nach Dateinamen mit einem bestimmten Muster zu suchen. Im nachfolgenden Makro habe ich in der Variablen "QuellDateien$" dieses Suchmuster für die Suche im Verzeichnis "C:\Test\" nach "*.xlsm"-Dateien hinein verpackt - muss folglich an deine Verhältnisse angepasst werden.
Ebenso wirst du eine Anpassung des Pfades (+Dateinamens) der Zieldatei, in die du kopieren willst, vornehmen müssen (Variable "Zielmappe$").

Code:

Option Explicit

Sub Daten_ziehen()
  Dim ZielMappe$
  Dim QuellDateien$, QuellDateiAktuell$
  Dim wbkZiel As Workbook

  With Application
    .ScreenUpdating = False
    .EnableEvents = False
  End With
 
  ZielMappe$ = "Baugruppen_Checkliste_2015.xlsm" '<---- Anpassen!!
  QuellDateien$ = "C:\test\*.xlsm"   '<--- Lw:\Pfad\Dateimaske - Anpassen!!

  'Öffnen der Zielmappe
  Set wbkZiel = Workbooks.Open(Filename:=ZielMappe$)
  
  'Vorbesetzen des Dir(), Öffnen der ersten Quellmappe
  QuellDateiAktuell$ = Dir(PathName:=QuellDateien$, Attributes:=vbNormal)
  
  'Schleife, in der zuerst überprüft wird,
  'ob noch eine Quellmappe vorhanden ist:
  Do Until Len(QuellDateiAktuell$) = 0
  
     'Öffnen der aktuellen Quellmappe
     With Workbooks.Open(Filename:=QuellDateiAktuell$)
       'Kopieren Blatt1 von Quellmappe hinter Blatt1 der Zielmappe
       .Sheets(1).Copy After:=wbkZiel.Sheets(1)
       'Schließen der Quellmappe
       .Close
     End With
     
     'Nächste Quellmappe holen mit bereits vorbesetztem Dir()
     QuellDateiAktuell$ = Dir()
     'Falls keine Quellmappe mehr vorhanden, dann Quellmappe=""
  Loop
  
  'Zielmappe schließen und Änderungen speichern
  wbkZiel.Close SaveChanges:=True
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
  End With
  
End Sub

 

Hallo,

hatte mir auch dieses Problem angeschaut und musste gerade feststellen, dass Exl schon eine Lösung abgeliefert hat. Aber meine werde ich auch dazu packen. Vom Aufbau unterscheiden sich beide nicht all zu sehr. Ich bin davon ausgegangen, dass du die einzelnen Tabellenblätter in die Datei kopieren willst, von der das Makro gestartet wird. Zur Übersicht wird jedes neu erstelltes Tabellenblatt mit dem Dateinamen der Quelldatei versehen und chronologisch sortiert.

Code:

Sub Daten_Schleife()

Dim WS As Worksheet
Dim StrFile$, WBPfad$, WSName$

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

WBPfad = "C:\OfficeTest\Testdateien\" 'Verzeichnis in dem alle Excel-Dateien liegen
StrFile = Dir(WBPfad)

Do While Len(StrFile) > 0                                                 'Schleifenstart mit Prüfung ob Länge des Namens größer 0 ist
    If Right$(StrFile, 3) = "xls" Or Right$(StrFile, 4) = "xlsx" Then     'Prüfung ob Dateiendung eine Excel-Datei ist; weitere Endungen einfach mit "Or" hinzufügen
            If Right$(StrFile, 4) = ".xls" Then                            'Abschneiden der ".xls"-Endungen für den Blattnamen
                WSName = Left(StrFile, Len(StrFile) - 4)                 'Abschneiden von ".xls"
            ElseIf Right$(StrFile, 5) = ".xlsx" Then                     'Weitere Prüfung zum Abschneiden von ".xlsx"
                WSName = Left(StrFile, Len(StrFile) - 5)                 'Abschneiden von ".xlsx"
            End If                                                        'Falls weitere Endungen vorhanden sind, über "Elseif" hinzufügen
            Set WS = ThisWorkbook.Worksheets.Add                        'Neues Tabellenblatt hinzufügen

            With WS
                .Name = WSName                                            'Tabellenname aus den gekürzten Dateinamen geben
                .Move after:=Sheets(Sheets.Count)                        'Tabellenblatt nach hinten verschieben
            End With

            Set WS = ThisWorkbook.Sheets(WSName)
            Workbooks.Open (WBPfad & StrFile)                            'Öffnen der Dateien aus dem festgelegten Ordner

        With WS
            ActiveWorkbook.Sheets(1).UsedRange.Copy _                    'Aus geöffneter Datei das erste Tabellenblatt kopieren
                 Destination:=.Range("A1")                                'und in das neu angelegte Tabellenblatt einfügen
        End With

        ActiveWorkbook.Close savechanges:=False                            'Schließen der Quelldatei ohne die Datei zu Speichern

        Endif
        StrFile = Dir
Loop

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

End Sub

Lg Chrischi