Einen Bereich aus 428 Excel Dateien in einer zusammenfassen

[Cole]

Hallo Leute,

ich habe ein kleines Problem, hoffe ihr seid so nett und könnt mir helfen!
In einem Ordner habe ich viele Excel Dateien (428 um genau zu sein), ich benötige aus jeder einzelnen Datei den Bereich A7-C132 in einer einzelnen Excel Datei untereinander (Datei nach Datei) zusammengefasst.

Ich habe schon mehrere Stunden gesucht, jedoch ohne Erfolg. Immer wieder stoße ich auf einzelne Zellen in einer Datei zu verknüpfen oder den Bereich aus einer Datei in eine andere zu kopieren… nichts davon konnte ich anpassen…

Hoffe ihr könnt mir da weiterhelfen!

Vielen Dank & Liebe Grüße,
Cole

[gmg-cc]

Moin Cole,
das sollte entweder mit VBA machbar sein aber auch ohne Programmierung mit Power Query. Schau mal hier nach, das sollte dir die eine oder andere Idee geben. Ich selbst löse das für mich (und meine Kunden) jetzt so gut wie immer mit Power Query.

[Packman]

Hallo Cole 

Probier mal!

Gruß Packman

Code: [Auswählen]

Sub DateienLesen()
Call EventsOff
    Dim DateiName As String
    DateiName = Dir(OrdnerAuswahl & "\" & "*.xls")
    Do While DateiName <> ""
        If ThisWorkbook.Name <> DateiName Then
            Workbooks.Open Filename:=Dpfad & DateiName
            Workbooks(DateiName).Worksheets(1).Range("A7:C132").Copy
            ThisWorkbook.Worksheets(1).Range("A" & ThisWorkbook.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
            Workbooks(DateiName).Close SaveChanges:=False
        End If
        DateiName = Dir
    Loop
    Call EventsOn
End Sub
Function OrdnerAuswahl() As String
    On Error GoTo FehlerRoutine
    Dim AppShell As Object
    Dim BrowseDir As Variant
    Set AppShell = CreateObject("Shell.Application")
    Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen", &H1000, 17)
    OrdnerAuswahl = BrowseDir.items().Item().Path & "\"
FehlerRoutine:
End Function
Public Sub EventsOff()
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
End Sub
Public Sub EventsOn()
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

[Packman]

Hallo Cole 

ops

Diese Zeile korrigieren

Code: [Auswählen]

Workbooks.Open Filename:=Dpfad & DateiName

Dpfad &
kann noch gelöscht werden!

Gruß Packman

[Packman]

Hallo Cole 

Nochmal überarbeitet 

Gruß Packman

Code: [Auswählen]

Sub DateienLesen()
    Call EventsOff
    Dim DateiName As String, Dpfad As String
    Dpfad = OrdnerAuswahl
    DateiName = Dir(Dpfad & "*.xls")
    Do While DateiName <> ""
        If ThisWorkbook.Name <> DateiName Then
            Workbooks.Open Filename:=Dpfad & DateiName
            Workbooks(DateiName).Worksheets(1).Range("A7:C132").Copy
            ThisWorkbook.Worksheets(1).Range("A" & ThisWorkbook.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
            Workbooks(DateiName).Close SaveChanges:=False
        End If
        DateiName = Dir
    Loop
    Call EventsOn
End Sub
Function OrdnerAuswahl() As String
    On Error GoTo FehlerRoutine
    Dim AppShell As Object
    Dim BrowseDir As Variant
    Set AppShell = CreateObject("Shell.Application")
    Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen", &H1000, 17)
    OrdnerAuswahl = BrowseDir.items().Item().Path & "\"
FehlerRoutine:
End Function
Public Sub EventsOff()
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
End Sub
Public Sub EventsOn()
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub