Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1068to1072
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Dateien zusammenfügen

Dateien zusammenfügen
25.04.2009 16:40:50
Ron
Hallo,
ich versuche gerade eine Tabelle aus allen in einem Verzeichnis stehenden xls-Dateien in einer neuen Tabelle zusammenzuführen. Habe dazu einige Anregungen im Forum gefunden. Allerdings macht das Makro noch nicht das, was ich will...
Im Quelltabellenblatt stehen Daten ab Zeile 15 (Spalte A und B sind leer und ausgeblendet). Bei der Konsolidierung wird jede gewünschte Datei eröffnet und jeweils ab Zeile 15 wieder in meine neue Datei geschrieben (Makro findet nicht den "richtigen" Einfügebereich). Ich möchte in der Zieldatei aber alle Einträge untereinander haben, Hier mal der verwendete Script. Ich hoffe, dass mir jemand helfen kann!!
Vielen Dank schon mal im voraus...
Ron

Sub Dateien_in_eine_Tabelle_zusammenfuehren()
Dim Datei As String
Dim Arbeitsmappe As String
Dim Pfad As String
Pfad = "c:\temp\zahlen\"
Datei = Dir(Pfad & "*.xls")
Application.ScreenUpdating = False
'Active Mappe
Arbeitsmappe = ActiveWorkbook.Name
Do While Datei  ""
'Öffnet eine Datei
Workbooks.Open Datei
'Kopiert von den Zeilen 15 bis zum Ende
'in die aktive Mappe und fügt sie jeweils unten an
Sheets("Daten kum").Select
Rows("15:" & ActiveWorkbook.ActiveSheet.Range("A65536").End(xlDown).Row).Copy _
Destination:=Workbooks(Arbeitsmappe).ActiveSheet.Range("A65536").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


7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
ungetestet
25.04.2009 16:54:04
Tino
Hallo,
versuche es mal so, habe es jetzt aber nicht getestet.
Sub Dateien_in_eine_Tabelle_zusammenfuehren()
Dim Datei As String, Pfad As String
Dim rZelle As Range
Dim objDatei As Workbook

Pfad = "c:\temp\zahlen\"
Datei = Dir$(Pfad & "*.xls")

Application.ScreenUpdating = False

Do While Datei <> ""
        
        'nächste freie Zelle bestimmen 
        With ThisWorkbook.ActiveSheet
         Set rZelle = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
        End With
        
        'Öffnet eine Datei 
        Set objDatei = Workbooks.Open(Datei, , True)
        
        'Kopiert von den Zeilen 15 bis zum Ende 
        With objDatei.Sheets("Daten kum")
         .Rows("15:" & .Cells(.Rows.Count, 1).Row).Copy rZelle
        End With
    
    'Schliesst die geöffnete Datei 
    objDatei.Close False
    'Prüft für die nächste Datei 
    Datei = Dir$()
Loop
Application.ScreenUpdating = True
End Sub


Gruß Tino

Anzeige
AW: ungetestet
25.04.2009 17:32:43
Ron
Hallo Tino,
vielen Dank erst einmal für Deine Antwort. Leider funzt es noch immer nicht. Dateien werden geöffnet, in der Quelldatei wird immer ab Zeile 15 sauber ausgelesen, jedoch wird in der Zieldatei immer ab Zeile 15 eingefügt und damit die Werte der vorherigen Übertragung "vernichtet"...
Bin wie gesagt ratlos...
Grüße
Ron
AW: ungetestet
25.04.2009 17:47:55
Tino
Hallo,
ich gehe davon aus, dass in Spalte A nichts steht.
Versuche es mal so.
Sub Dateien_in_eine_Tabelle_zusammenfuehren()
Dim Datei As String, Pfad As String
Dim rZelle As Range
Dim objDatei As Workbook
Dim LRow As Long
Pfad = "c:\temp\zahlen\"
Datei = Dir$(Pfad & "*.xls")

Application.ScreenUpdating = False

Do While Datei <> ""
        
        'nächste freie Zelle bestimmen 
        With ThisWorkbook.ActiveSheet
         On Error Resume Next
          LRow = .Cells.Find("*", , xlValues, 2, 1, 2, False, False, False).Row
          LRow = Application.Max(LRow, .Cells.Find("*", , xlFormulas, 2, 1, 2).Row)
         On Error GoTo 0
          
         LRow = LRow + 1
         Set rZelle = .Cells(LRow, 1)
        End With
        
        'Öffnet eine Datei 
        Set objDatei = Workbooks.Open(Datei, , True)
        
        'Kopiert von den Zeilen 15 bis zum Ende 
        With objDatei.Sheets("Daten kum")
         .Rows("15:" & .Cells(.Rows.Count, 1).Row).Copy rZelle
        End With
    
    'Schliesst die geöffnete Datei 
    objDatei.Close False
    'Prüft für die nächste Datei 
    Datei = Dir$()
Loop
Application.ScreenUpdating = True
End Sub


Gruß Tino

Anzeige
AW: ungetestet --> um ganz sicher zu gehen
25.04.2009 17:59:52
Tino
Hallo,
..., könnten wir dies auch gleich richtig machen.
Immer noch ungetestet. ;-)
Sub Dateien_in_eine_Tabelle_zusammenfuehren()
Dim Datei As String, Pfad As String
Dim rZelle As Range
Dim objDatei As Workbook
Dim LRow As Long
Pfad = "c:\temp\zahlen\"
Datei = Dir$(Pfad & "*.xls")

Application.ScreenUpdating = False

Do While Datei <> ""
        
        'nächste freie Zelle bestimmen 
        With ThisWorkbook.ActiveSheet
         On Error Resume Next
          LRow = .Cells.Find("*", , xlValues, 2, 1, 2, False, False, False).Row
          LRow = Application.Max(LRow, .Cells.Find("*", , xlFormulas, 2, 1, 2).Row)
         On Error GoTo 0
          
         LRow = LRow + 1
         Set rZelle = .Cells(LRow, 1)
        End With
        LRow = 0
        
        'Öffnet eine Datei 
        Set objDatei = Workbooks.Open(Datei, , True)
        
        'Kopiert von den Zeilen 15 bis zum Ende 
        With objDatei.Sheets("Daten kum")
         On Error Resume Next
          LRow = .Cells.Find("*", , xlValues, 2, 1, 2, False, False, False).Row
          LRow = Application.Max(LRow, .Cells.Find("*", , xlFormulas, 2, 1, 2).Row)
         On Error GoTo 0
         
         If LRow > 14 Then
          .Rows("15:" & .Cells(.Rows.Count, 1).Row).Copy rZelle
         End If
        End With
        
        LRow = 0
    'Schliesst die geöffnete Datei 
    objDatei.Close False
    'Prüft für die nächste Datei 
    Datei = Dir$()
Loop
Application.ScreenUpdating = True
End Sub


Gruß Tino

Anzeige
Korrektur...
25.04.2009 18:18:01
Tino
Option Explicit

Sub Dateien_in_eine_Tabelle_zusammenfuehren()
Dim Datei As String, Pfad As String
Dim rZelle As Range
Dim objDatei As Workbook
Dim LRow As Long
Pfad = "c:\temp\zahlen\"
Datei = Dir$(Pfad & "*.xls")

Application.ScreenUpdating = False

Do While Datei <> ""
        
        'nächste freie Zelle bestimmen 
        With ThisWorkbook.ActiveSheet
         On Error Resume Next
          LRow = .Cells.Find("*", , xlValues, 2, 1, 2, False, False, False).Row
          LRow = Application.Max(LRow, .Cells.Find("*", , xlFormulas, 2, 1, 2).Row)
         On Error GoTo 0
          
         LRow = LRow + 1
         Set rZelle = .Cells(LRow, 1)
        End With
        LRow = 0
        
        'Öffnet eine Datei 
        Set objDatei = Workbooks.Open(Datei, , True)
        
        'Kopiert von den Zeilen 15 bis zum Ende 
        With objDatei.Sheets("Daten kum")
         On Error Resume Next
          LRow = .Cells.Find("*", , xlValues, 2, 1, 2, False, False, False).Row
          LRow = Application.Max(LRow, .Cells.Find("*", , xlFormulas, 2, 1, 2).Row)
         On Error GoTo 0
         
         If LRow > 14 Then
          .Rows("15:" & LRow).Copy rZelle
         End If
        End With
        
        LRow = 0
    'Schliesst die geöffnete Datei 
    objDatei.Close False
    'Prüft für die nächste Datei 
    Datei = Dir$()
Loop
Application.ScreenUpdating = True
End Sub


Anzeige
AW: ungetestet
25.04.2009 17:48:47
Daniel
Hi
könnte es sein, daß die Spalte A keine Werte enthält?
welche Spalte der Daten ist denn immer mit Daten gefüllt und enthält keine Leerzellen?
diese müsste man dann hier verwenden (als Beispiel, wenn es die Spalte E wäre, die immer Daten enthält::

Set rZelle = .Cells(.Rows.Count, 5).End(xlUp).Offset(1, -4)


Gruß, Daniel

AW: ungetestet
25.04.2009 20:42:43
Ron
Hallo Daniel,
hallo Tino,
vielen Dank für Eure Hilfe - endlich funzt es. Werde weiter lernen, um dann nicht mehr so blöde Fragen zu stellen. Muß einfach immer wieder feststellen - Excel und die darin steckenden Möglichkeiten sind absolut genial ...
Liebe Grüße an Euch und noch ein schönes Restwochenende!!!
Ron
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige