✔ Tabellen zusammenführen Code ändern

T

Thor_sten

Mitglied
Hallo liebe Forumsgemeinde, ich hab mal wieder eine Frage.:rolleyes:

Ich benutze momentan folgenden Code um alle Tabellen aus einen bestimmten Ordner in einer neuen Datei zusammenzufassen.

Code: 
Sub MWTabellenAusMehrerenDateienEinlesen()
   Dim oTargetSheet As Object
   Dim oSourceBook As Object
   Dim sPfad As String
   Dim sDatei As String
   Dim lErgebnisZeile As Long
   Dim s As Long
   Dim z As Long
 
     Application.ScreenUpdating = False 'Das "Flackern" ausstellen
   
     'Schritt 1: Neues Arbeitsblatt für die Ergebnisse erstellen
     Set oTargetSheet = ActiveWorkbook.ActiveSheet
     lErgebnisZeile = 1 'Ergebnisse eintragen ab Zeile 1
   
     'Schritt 2: Schleife über alle Excel Dateien in einem Verzeichnis
     sPfad = "C:\test3\"
     sDatei = Dir(CStr(sPfad & "*.xl*")) 'Alle Excel Dateien
   
     Do While sDatei <> ""
   
         'Schritt 3: öffnen der Datei und Datenübertragung
         Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True) 'nur lesend öffnen
       
         'Datenübertragung alle genutzten Zeilen und Spalten
         For z = 1 To oSourceBook.Sheets("Tabelle1").UsedRange.Rows.Count
             'Keine Leerzeilen verarbeiten
             If Trim(CStr(oSourceBook.Sheets("Tabelle1").Cells(z, 1).Value)) <> "" Then
                 For s = 1 To oSourceBook.Sheets("Tabelle1").UsedRange.Columns.Count
                     'Spalte 2 bis n - Tabelleninhalte des Arbeitsblattes "Tabelle1"
                     oTargetSheet.Cells(lErgebnisZeile, s).Value = _
                         oSourceBook.Sheets("Tabelle1").Cells(z, s).Value
                 Next s
                 lErgebnisZeile = lErgebnisZeile + 1
             End If
         Next z
       
         'Schritt 4: Datei wieder zu machen und nächste Schleifenrunde
         oSourceBook.Close False 'nicht speichern
       
         'Nächste Datei
         sDatei = Dir()
     Loop
   
     Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten
   
     'Variablen aufräumen
     Set oTargetSheet = Nothing
     Set oSourceBook = Nothing
End Sub

Der aktuelle Code kopiert die Tabellen ab Zeile 1 und fügt alle zusammengefasst in Zeile 1 im neuen Dokument zusammen.
Die zu importierenden Dateien sollen ab Zeile 2 kopiert werden und ab Zeile 2 eingefügt werden, da ich in dem zusammengeführten Dokument mit einer Wiederholungszeile arbeite.

Und ob und falls ja, wie es möglich ist, die zu importierenden Daten aus dem Ordner auszuwählen, anstatt gleich alle zu importieren?

Vielleicht hat ja einer eine Idee oder eine Lösung dazu.


Viele Grüße

Thorsten
 
Hallo Drogist,
vielen Dank schonmal für deine Antwort. Ja, Power Query hatte ich auch schon im Kopf. Habe das dann aber wieder verworfen, weil der oben gepostete Code nur ein Teil meiner Komplettlösung ist.
Somit strebe ich eine Lösung duch einenen VBA-Code an. Ansonsten müsste ich mein komplettes Konzept und meine bisherige Arbeit über den Haufen werfen. Um das gesamte Thema für mich abzuschließen fehlt mir nur noch dieser eine Baustein.


Viele Grüße

Thorsten
 
Zuletzt bearbeitet:
Ist ein wenig kompliziert, Zelle um Zelle zu kopieren. Mindestens Zeile um Zeile darf schon sein
Visual Basic: 
Public Sub t405646()
   
    'Ziel
    Dim trgWb As Workbook
    Dim trgWs As Worksheet
    Dim trgRow As Long
    'Quelle
    Dim srcWb As Workbook
    Dim srcWs As Worksheet
    Dim srcRowNr As Long
    Dim srcPath As Variant
   
    'Filedialog
    Dim fd As FileDialog
   
    'Ziel definieren
    Set trgWb = ActiveWorkbook
    Set trgWs = trgWb.Worksheets("Sheet1")
    trgRow = 2
   
    'Filedialog definieren
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    fd.InitialFileName = trgWb.Path
    fd.Filters.Add "Excel Files", "*.xlsx"
    fd.Filters.Add "All Files", "*.*"
    fd.Title = "Import FIles auswählen"
    fd.Show
   
    'Keine Dateien ausgewählt. Funktion verlassen
    If fd.SelectedItems.Count = 0 Then Exit Sub
   
    'Alle ausgewählten Dateien durchgehen
    For Each srcPath In fd.SelectedItems
        Set srcWb = Workbooks.Open(srcPath, , True)
        Set srcWs = srcWb.Worksheets("Sheet1")
        'Alle Zeilen durchgehen
        For srcRowNr = 2 To srcWs.Cells.SpecialCells(xlCellTypeLastCell).Row
            'Prüfen dass die Zeile nicht leer ist
            If WorksheetFunction.CountA(srcWs.Rows(srcRowNr)) <> 0 Then
                'Zeile kopieren
                srcWs.Rows(srcRowNr).Copy trgWs.Cells(trgRow, 1)
                trgRow = trgRow + 1
            End If
        Next
        srcWb.Close False
    Next srcPath
   
End Sub
 
Okay, der Code ist plausibel und nachvollziehbar für mich. Ich habe versucht das Makro testweise für sich zu starten. Wenn ich das Makro jedoch starte, wird es nicht ausgeführt. Der Cursor springt lediglich in die oben genannte Zeile (405646).
Woran liegt es?
 
Hey, super klappt. Ich musste lediglich "Sheet1" in "Tabelle1" umbenennen. Das liegt dann wohl an meiner deutschen Version.

Vielen Dank Yaslaw!
 
Hallo nochmal, ein Problem ist doch noch aufgetaucht:

Ich habe deinen Code aus t405646.zip mit den vorherigen Makros (sortieren, Duplikate entfernen und einfärben) zusammengefügt und lasse diese hintereinander ausführen.
Das funktioniert auch alles, bis auf eine Kleinigkeit: beim Sortieren und einfärben verschiebt sich der Inhalt in Zeile 1. Solange t405646 ausgeführt wird, bleibt Zeile 1 wie gewünscht frei.
Daher wird der Fehler im nachfolgenden Makro sein (test).

Hier ein Screenshot wie es aktuell aussieht:

Und hier ein Screenshot wie es aussehen sollte:

Anbei auch noch die komplette Datei.

Sorry für den nachträglichen Post und das ewige Nachfragen. Danach ist das Thema dann auch wirklich beendet.


Besten Dank und Viele Grüße!

Thor_sten
 

Anhänge

Die Funktion removeDoubleValuesInColumns um den Paramter iStartRow erweitern
Visual Basic: 
Public Sub removeDoubleValuesInColumns(ByRef iWs As Worksheet, ByRef iColumns() As Variant, Optional ByVal iStartRow As Long = 1)
    ...
   'Alle Zeilen durchgehen
   For rowNr = iStartRow To iWs.Cells.SpecialCells(xlCellTypeLastCell).Row
    ...
Und anschliessend in test() die Zeile 2 als Start mitgeben
Visual Basic: 
    removeDoubleValuesInColumns ws, cols, 2
 
Um antworten zu können musst du eingeloggt sein.

Neue Beiträge

Zurück