1. Diese Seite verwendet Cookies. Wenn du dich weiterhin auf dieser Seite aufhältst, akzeptierst du unseren Einsatz von Cookies. Weitere Informationen

Tabellen zusammenführen Code ändern

Dieses Thema im Forum "Office-Anwendungen" wurde erstellt von Thor_sten, 8. August 2017.

  1. Thor_sten

    Thor_sten Grünschnabel

    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 (Text):
    1. Sub MWTabellenAusMehrerenDateienEinlesen()
    2.    Dim oTargetSheet As Object
    3.    Dim oSourceBook As Object
    4.    Dim sPfad As String
    5.    Dim sDatei As String
    6.    Dim lErgebnisZeile As Long
    7.    Dim s As Long
    8.    Dim z As Long
    9.  
    10.      Application.ScreenUpdating = False 'Das "Flackern" ausstellen
    11.    
    12.      'Schritt 1: Neues Arbeitsblatt für die Ergebnisse erstellen
    13.      Set oTargetSheet = ActiveWorkbook.ActiveSheet
    14.      lErgebnisZeile = 1 'Ergebnisse eintragen ab Zeile 1
    15.    
    16.      'Schritt 2: Schleife über alle Excel Dateien in einem Verzeichnis
    17.      sPfad = "C:\test3\"
    18.      sDatei = Dir(CStr(sPfad & "*.xl*")) 'Alle Excel Dateien
    19.    
    20.      Do While sDatei <> ""
    21.    
    22.          'Schritt 3: öffnen der Datei und Datenübertragung
    23.          Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True) 'nur lesend öffnen
    24.        
    25.          'Datenübertragung alle genutzten Zeilen und Spalten
    26.          For z = 1 To oSourceBook.Sheets("Tabelle1").UsedRange.Rows.Count
    27.              'Keine Leerzeilen verarbeiten
    28.              If Trim(CStr(oSourceBook.Sheets("Tabelle1").Cells(z, 1).Value)) <> "" Then
    29.                  For s = 1 To oSourceBook.Sheets("Tabelle1").UsedRange.Columns.Count
    30.                      'Spalte 2 bis n - Tabelleninhalte des Arbeitsblattes "Tabelle1"
    31.                      oTargetSheet.Cells(lErgebnisZeile, s).Value = _
    32.                          oSourceBook.Sheets("Tabelle1").Cells(z, s).Value
    33.                  Next s
    34.                  lErgebnisZeile = lErgebnisZeile + 1
    35.              End If
    36.          Next z
    37.        
    38.          'Schritt 4: Datei wieder zu machen und nächste Schleifenrunde
    39.          oSourceBook.Close False 'nicht speichern
    40.        
    41.          'Nächste Datei
    42.          sDatei = Dir()
    43.      Loop
    44.    
    45.      Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten
    46.    
    47.      'Variablen aufräumen
    48.      Set oTargetSheet = Nothing
    49.      Set oSourceBook = Nothing
    50. 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
     
  2. Drogist

    Drogist Erfahrenes Mitglied

    Moin Thorsten,
    ich habe zumindest eine Idee ...
    Kannst/darfst/willst du Power Query -> http://www.excel-ist-sexy.de/power-query-das-add-in/ nutzen?
    Damit sollte nämlich dein Wunsch erfüllbar sein. Allerdings ohne eine einzige Zeile VBA-Code, dennoch mit einem hohen Maß an Automatismus. ;)
    Allerdings wirst du einiges neu lernen müssen ...
     
  3. Thor_sten

    Thor_sten Grünschnabel

    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: 23. August 2017
  4. Yaslaw

    Yaslaw n/a Moderator

    Ist ein wenig kompliziert, Zelle um Zelle zu kopieren. Mindestens Zeile um Zeile darf schon sein
    Code (Visual Basic):
    1. Public Sub t405646()
    2.    
    3.     'Ziel
    4.    Dim trgWb As Workbook
    5.     Dim trgWs As Worksheet
    6.     Dim trgRow As Long
    7.     'Quelle
    8.    Dim srcWb As Workbook
    9.     Dim srcWs As Worksheet
    10.     Dim srcRowNr As Long
    11.     Dim srcPath As Variant
    12.    
    13.     'Filedialog
    14.    Dim fd As FileDialog
    15.    
    16.     'Ziel definieren
    17.    Set trgWb = ActiveWorkbook
    18.     Set trgWs = trgWb.Worksheets("Sheet1")
    19.     trgRow = 2
    20.    
    21.     'Filedialog definieren
    22.    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    23.     fd.InitialFileName = trgWb.Path
    24.     fd.Filters.Add "Excel Files", "*.xlsx"
    25.     fd.Filters.Add "All Files", "*.*"
    26.     fd.Title = "Import FIles auswählen"
    27.     fd.Show
    28.    
    29.     'Keine Dateien ausgewählt. Funktion verlassen
    30.    If fd.SelectedItems.Count = 0 Then Exit Sub
    31.    
    32.     'Alle ausgewählten Dateien durchgehen
    33.    For Each srcPath In fd.SelectedItems
    34.         Set srcWb = Workbooks.Open(srcPath, , True)
    35.         Set srcWs = srcWb.Worksheets("Sheet1")
    36.         'Alle Zeilen durchgehen
    37.        For srcRowNr = 2 To srcWs.Cells.SpecialCells(xlCellTypeLastCell).Row
    38.             'Prüfen dass die Zeile nicht leer ist
    39.            If WorksheetFunction.CountA(srcWs.Rows(srcRowNr)) <> 0 Then
    40.                 'Zeile kopieren
    41.                srcWs.Rows(srcRowNr).Copy trgWs.Cells(trgRow, 1)
    42.                 trgRow = trgRow + 1
    43.             End If
    44.         Next
    45.         srcWb.Close False
    46.     Next srcPath
    47.    
    48. End Sub
     
    Thor_sten gefällt das.
  5. Thor_sten

    Thor_sten Grünschnabel

    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?
     
  6. Yaslaw

    Yaslaw n/a Moderator

    Wie startest du?
     

    Anhänge:

    Thor_sten gefällt das.
  7. Thor_sten

    Thor_sten Grünschnabel

    Hey, super klappt. Ich musste lediglich "Sheet1" in "Tabelle1" umbenennen. Das liegt dann wohl an meiner deutschen Version.

    Vielen Dank Yaslaw!
     
  8. Thor_sten

    Thor_sten Grünschnabel

    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:
    [​IMG]
    Und hier ein Screenshot wie es aussehen sollte:
    [​IMG]
    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:

    • Test.zip
      Dateigröße:
      45 KB
      Aufrufe:
      2
  9. Yaslaw

    Yaslaw n/a Moderator

    Die Funktion removeDoubleValuesInColumns um den Paramter iStartRow erweitern
    Code (Visual Basic):
    1. Public Sub removeDoubleValuesInColumns(ByRef iWs As Worksheet, ByRef iColumns() As Variant, Optional ByVal iStartRow As Long = 1)
    2.     ...
    3.    'Alle Zeilen durchgehen
    4.   For rowNr = iStartRow To iWs.Cells.SpecialCells(xlCellTypeLastCell).Row
    5.     ...
    Und anschliessend in test() die Zeile 2 als Start mitgeben
    Code (Visual Basic):
    1.     removeDoubleValuesInColumns ws, cols, 2
     
    Thor_sten gefällt das.
  10. Thor_sten

    Thor_sten Grünschnabel

    Ich habe das eingesetzt, wie in der angehängten Datei zu sehen. Aber die erste Zeile bleibt weiterhin nicht frei.
     

    Anhänge:

  11. Yaslaw

    Yaslaw n/a Moderator

    Komisch. in meinem Test hats funktioniert.
    Hast du den Aufruf angepasst?

    Leider hat mein PC imMoment keine Kapazitäten um irgendwas zu teste. Er läuft gerade einen Process durch und ist bei etwa 180% Auslastung.
     
    Thor_sten gefällt das.
  12. Yaslaw

    Yaslaw n/a Moderator

    Do solltest nicht nur kopieren sondern versuchen zu verstehen. Dann findest du auch heraus wo du schrauben musst.
     
    Thor_sten gefällt das.
  13. Thor_sten

    Thor_sten Grünschnabel

    Ich versuche ja es zu verstehen und kann auch einiges nachvollziehen aber die Komplexität übersteigt mein Wissen in diesem Bereich völlig.
    Ich habe den Aufruf (test) angepasst und die Remove Funktion um iStartRow erweitert. Trotzdem funktioniert es nicht oder ich vestehe den Gesamtzusammenhang einfach nicht.

    Code (Text):
    1. Public Sub test()
    2.     'Die Spalten definieren, die betroffen sind
    3.    'In dem Beispiel A und B
    4.    Dim cols() As Variant
    5.     cols = Array(1, 2)
    6.  
    7.     'Das zu bearbeitende Worksheet auswählen
    8.    Dim ws As Worksheet
    9.     Set ws = ActiveWorkbook.Sheets(1)
    10.     removeDoubleValuesInColumns ws, cols, 2
    11. End Sub
    Code (Text):
    1. '/**
    2. ' * Entfernt in vorgewählten Spalten die doppelten Werte
    3. ' * @param    Dim ws As Worksheet             'Worksheet mit den zu bearbeitenden Daten
    4. ' * @param Array<Long>  Array mit den Spaltennummern, die sortiert/bearbeitet werden sollen
    5. ' *                     Währe es A, C und D, müsste der Array so aussehen: Array(1, 3, 4)
    6. ' */
    7. Public Sub removeDoubleValuesInColumns(ByRef iWs As Worksheet, ByRef iColumns() As Variant, Optional ByVal iStartRow As Long = 1)
    8.     Dim rowNr As Long               'Zeilennummern
    9.    Dim lastValues() As Variant     'Werte der Vorzeile pro Spalte
    10.    Dim idx As Long                 'Index um durch die 2 Arrays zu iterieren
    11.    Dim ref As Long                 'Index von Hinten gerechnet
    12.    Dim isFirstOfGroup As Boolean   'Flag ob die Zeile ein Gruppenanfang ist
    13.    Dim alternateColor As Boolean        'Nach jeder Gruppe switcht dieser Wert: false -> true -> false -> true
    14.    
    15.     'Sortierungen entfernen
    16.    iWs.Sort.SortFields.Clear
    17.     'Spalte zur Sortierung hinzufügen
    18.    For idx = LBound(iColumns) To UBound(iColumns)
    19.         iWs.Sort.SortFields.Add iWs.Columns(iColumns(idx))
    20.     Next idx
    21.     'befüllter Bereich zum Sortieren auswählen
    22.    iWs.Sort.SetRange iWs.UsedRange
    23.  
    24.         'Ziel definieren
    25.     Set trgWb = ActiveWorkbook
    26.     Set trgWs = trgWb.Worksheets("Sheet1")
    27.     trgRow = 2
    28.  
    29.     'Sortierung anwenden
    30.    iWs.Sort.Apply
    31.     'Letze Werte für den Vergleich initialisieren
    32.    ReDim lastValues(LBound(iColumns) To UBound(iColumns))
    33.     'Alle Zeilen durchgehen
    34.    For rowNr = iStartRow To iWs.Cells.SpecialCells(xlCellTypeLastCell).Row
    35.         'Standardwert setzen
    36.        isFirstOfGroup = True
    37.         'Alle betroffenen Spalten von Vorne nach hinten durchgehen
    38.        For idx = LBound(iColumns) To UBound(iColumns)
    39.             'Prüfen ob Feld in der Spalte A mit dem letzten Wert übereinstimme
    40.            If iWs.Cells(rowNr, iColumns(idx)).Value = lastValues(idx) Then
    41.                 'Wenn ja, Feld mit Null überschreiben
    42.                iWs.Cells(rowNr, iColumns(idx)).Value = Null
    43.                 'Ist kein Gruppenanfang
    44.                isFirstOfGroup = False
    45.             Else
    46.                 'Ansonsten den Wert als neuen Letzten Wert übernehmen
    47.                lastValues(idx) = iWs.Cells(rowNr, iColumns(idx)).Value
    48.                 'Alle späteren zu kontrollierenden Spalten zurücksetzen
    49.                For ref = UBound(iColumns) To idx + 1 Step -1
    50.                     lastValues(ref) = Null
    51.                 Next ref
    52.             End If
    53.         Next idx
    54.         'Farbe switchen
    55.        If isFirstOfGroup Then alternateColor = Not alternateColor
    56.         'Einfärben
    57.        iWs.Rows(rowNr).Interior.Color = IIf(alternateColor, rgbLightGrey, 0)
    58.         iWs.Rows(rowNr).Interior.Pattern = IIf(alternateColor, xlSolid, xlNone)
    59.     Next rowNr
    60. End Sub
     
  14. Yaslaw

    Yaslaw n/a Moderator

    Seh den Fehler gerade nicht.
    Hier meine Testdatei.
     

    Anhänge:

    • Y.zip
      Dateigröße:
      26,8 KB
      Aufrufe:
      2
    Thor_sten gefällt das.
  15. Thor_sten

    Thor_sten Grünschnabel

    Leider funktioniert die Testdatei nur bedingt. Kopieren und einfügen ab Zeile zwei funktioniert. Sobald ich aber Benennungen in Spalte eins eingebe (wozu sie frei bleiben sollte) und dann die Tabellen einfügen lasse, springt die Tabelle in Zeile eins und die Benenungen in die letzte Zeile.
    Die erste Zeile als Drucktitel zu deklarieren funktioniert auch nicht.
     
    Zuletzt bearbeitet: 6. September 2017
  16. Yaslaw

    Yaslaw n/a Moderator

    Neue Bedingungen gibt neue Herausforderungen. Das da Text von Anfang an drinstehen soll, davon lese ich jetzt zum ersten mal. Vorher war es das Sortieren einer kompletten Tabelle.
    Im Moment habe ich keine Zeit. weiter auf das Problem einzugehen.
    Versuch die Sortierfunktion zu verstehen. Alle VBA-Befehle sind mit F1 mit Hilfe hinterlegt. Zudem habe ich ganz viel Kommentare im Code drin.
     
    Thor_sten gefällt das.
  17. Thor_sten

    Thor_sten Grünschnabel

    Ich habe jetzt eine Lösung gefunden damit es nun alles so funktioniert wie ich es benötige.
    Vielen Dank für deine Bemühungen und Lösungen um mir bei dieser komplexen Aufgabe zu helfen Yaslaw.
    Auch wenn es wahrscheinlich sehr nervenaufreibend war.

    Danke!
     
Die Seite wird geladen...