Dateien Zusammenführen

Sub Dateien_in_eine_Tabelle_zusammenfuehren() '(C) Ramses Dim Datei As String Dim Arbeitsmappe As String Dim Pfad As String Pfad = "C:\Dokumente und Einstellungen\Carmen\Eigene Dateien\entgelte Periode\November" 'Pfad _ angepasst Datei = Dir(Pfad & "*.xlsx") Application.ScreenUpdating = False 'Active Mappe Arbeitsmappe = ActiveWorkbook.Name Do While Datei "" 'Öffnet eine Datei Workbooks.Open Datei 'Kopiert von den Zeilen 2 bis zum Ende 'in die aktive Mappe und fügt sie jeweils unten an Rows("2:" & ActiveWorkbook.ActiveSheet.Range("A1048576").End(xlUp).Row).Copy _ Destination:=Workbooks(Arbeitsmappe).ActiveSheet.Range("A1048576").End(xlUp).Offset(1, _ 0) 'Schliesst die geöffnete Datei ActiveWorkbook.Close False 'Prüft für die nächste Datei Datei = Dir() Loop Application.ScreenUpdating = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub NUR_Kompiliert() '(cu :-)Gerd Dim Datei As String Dim WB As Workbook, strWS As String Dim rngQ As Range, rngZ As Range Dim Pfad As String Pfad = "'C:\Dokumente und Einstellungen\Carmen\Eigene Dateien\entgelte Periode\November'" 'Pfad _ 'angepasst Datei = Dir(Pfad & "*.xlsx") Application.ScreenUpdating = False 'Active Mappe Set WB = ActiveWorkbook strWS = ActiveSheet.Name Do While Datei "" 'Öffnet eine Datei Workbooks.Open Datei 'Kopiert von den Zeilen 2 bis zum Ende 'in die aktive Mappe und fügt sie jeweils unten an Set rngQ = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp)).EntireRow Set rngZ = WB.Worksheets(strWS).Cells(WB.Worksheets(strWS).Rows.Count, 1).End(xlUp).Offset( _ 1, 0).Resize(rngQ.Rows.Count, rngQ.Columns.Count) rngQ.Copy Destination:=rngZ 'Schliesst die geöffnete Datei ActiveWorkbook.Close False 'Prüft für die nächste Datei Datei = Dir() Loop Application.ScreenUpdating = True End Sub

Sub NUR_Kompiliert() '(cu :-)Gerd Dim Datei As String Dim WB As Workbook, strWS As String Dim rngQ As Range, rngZ As Range Dim Pfad As String Pfad = "C:\Dokumente und Einstellungen\carmen\Eigene Dateien\Periode\November\" 'Pfad _ 'angepasst Datei = Dir(Pfad & "*.xlsx") Application.ScreenUpdating = False 'Active Mappe Set WB = ActiveWorkbook strWS = ActiveSheet.Name Do While Datei "" 'Öffnet eine Datei Workbooks.Open Datei 'Kopiert von den Zeilen 2 bis zum Ende 'in die aktive Mappe und fügt sie jeweils unten an Set rngQ = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp)).EntireRow Set rngZ = WB.Worksheets(strWS).Cells(WB.Worksheets(strWS).Rows.Count, 1).End(xlUp).Offset( _ _ 1, 0).Resize(rngQ.Rows.Count, rngQ.Columns.Count) rngQ.Copy Destination:=rngZ 'Schliesst die geöffnete Datei ActiveWorkbook.Close False 'Prüft für die nächste Datei Datei = Dir() Loop Application.ScreenUpdating = True End Sub

Hallo,
versuch es mal mit dieser Version.

Sub Dateien_in_eine_Tabelle_zusammenfuehren()
Dim strPfad As String
Dim oWBEx As Workbook
Dim rngNextCell As Range
Dim FileArray()
Dim LCount As Long, MaxRow As Long

'Pfad angepasst 
strPfad = "C:\Dokumente und Einstellungen\Carmen\Eigene Dateien\entgelte Periode\November"
'Suche Dateien im Ordner 
ListFilesInFolder FileArray, strPfad, "*.xlsx", False, LCount

'was gefunden? 
If LCount > 0 Then
Application.ScreenUpdating = False

    For LCount = Lbound(FileArray) To Ubound(FileArray)
       
        'Öffnet die Datei 
        Set oWBEx = Workbooks.Open(FileArray(LCount), ReadOnly:=True)
        
        'Kopiert von den Zeilen 2 bis zum Ende wenn ab Zeile 2 was vorhanden 
        'aktive Tabelle in dieser Datei 
        With ThisWorkbook.ActiveSheet
            'nächste freie Zelle 
            Set rngNextCell = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
            'erste Tabelle aus der externen Datei 
            With oWBEx.Worksheets(1)
                'letzte belegte Zelle 
                MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                'letzte belegte Zeile ist nicht Zeile 1 
                If MaxRow > 1 Then
                    'Daten kopieren 
                    .Range("A2", .Cells(MaxRow, 1)).EntireRow.Copy rngNextCell
                End If
                'Datei schließen 
                oWBEx.Close False
            End With 'oWBEx.Worksheets(1) 
        End With 'ThisWorkbook.ActiveSheet 
    
    Next LCount

Application.ScreenUpdating = True
End If

End Sub

Sub ListFilesInFolder(FileArray, SourceFolderName As String, Optional DateiFormat As String = "*.*", _
                        Optional IncludeSubfolders As Boolean = False, Optional LCount As Long = 0)

Dim FSO As Object, SourceFolder As Object, SubFolder As Object
Dim FileItem
Dim Status As Integer
 
 Set FSO = CreateObject("Scripting.FileSystemObject")
 
 If FSO.FolderExists(SourceFolderName) Then
     Set SourceFolder = FSO.GetFolder(SourceFolderName)
            
        On Error GoTo Err_Zugriff: 'sollte Ordner geschützt sein 
         
        For Each FileItem In SourceFolder.Files
            If LCase(FileItem) Like LCase(DateiFormat) Then
             Redim Preserve FileArray(LCount)
             FileArray(LCount) = FileItem
             LCount = LCount + 1
            End If
        Next FileItem
    
    
        If IncludeSubfolders Then
            For Each SubFolder In SourceFolder.SubFolders
                ListFilesInFolder FileArray, SubFolder.Path, DateiFormat, IncludeSubfolders, LCount
            Next SubFolder
        End If
 Else
       MsgBox "Ordner nicht gefunden!", vbCritical
 End If

Err_Zugriff:
Set FileItem = Nothing: Set SourceFolder = Nothing: Set FSO = Nothing
End Sub

Gruß Tino

Beliebteste Forumthreads (12 Monate)

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread