VBA Excel Zeilen vergleichen, bei unterschiedlichen Spalteninhalten diese zusammenführen

Liebes Forum,

ich bitte Euch bei meinem Problem um Hilfe.

Ich habe eine Excel-Tabelle mit Einträgen, die ich zusammenführen möchte:

Beispiel vorher:

Druckschrift	...	Thema	Bemerkung	Beurteilung	...
D1	...	Thema1	Bemerkung 1	a	...
D2	...	Thema2	Bemerkung 2	b	...
D3	...	Thema3	Bemerkung 1	c	...
D2	...	Thema3	Bemerkung 3	d	...
D1	...	Thema1	Bemerkung 4	e	...

Bei identischen Druckschriften (Spalte Druckschrift) sollen ggf. unterschiedliche Inhalte (Spalten Thema, Bemerkung, Beurteilung) zusammengeführt werden.

Beispiel nachher:

Druckschrift	...	Thema	Bemerkung	Beurteilung	...
D1	...	Thema1	Bemerkung 1, Bemerkung 4	a,e	...
D2	...	Thema2, Thema 3	Bemerkung 2, Bemerkung 3	b, d	...
D3	...	Thema3	Bemerkung 1	c	...

Hintergrund: Die Druckschriften werden von unterschiedlichen Personen zu unterschiedlichen Zeiten gelesen. Die Anzahl der Druckschriften liegt hierbei im Bereich von etwa 40.000, Tendenz steigend.

Unter http://www.herber.de/forum/archiv/1096to1100/t1099970.htm habe ich eine elegante Lösung mit einem CreateObject("Scripting.Dictionary") für 1 Spalte gefunden, ich konnte diese Lösung aber wegen mangelndem VBA-Wissen nicht anpassen.

Vielen Dank im Voraus mit Grüßen

Fusselfrei

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 144722

Url: https://administrator.de/contentid/144722

Ausgedruckt am: 26.11.2024 um 13:11 Uhr

7 Kommentare

Neuester Kommentar

Hallo Fusselfrei!

herber.de ist gut, und "Dictionary" genau das richtige Werkzeug - wenn es denn Excel (und nicht eine Datenbanklösung) sein soll ...

Aussehen könnte das VBA-Progrämmchen etwa so:

Sub Zusammenfassen()
ZielTabelle = "Tabelle2"  
Quelltabelle = "Tabelle1"  
AbZeile = 2 'Erste zu lesende / schreibende Zeile der Tabellen  
ErsteSpalte = "A" 'Spalte "Schrift"  
Spalten = Array("C", "D", "E") 'Spalten mit den zusammenzufassenden Einträgen  

SpaltenAnzahl = UBound(Spalten) 'Anzahl der Spalten ermitteln und ...  
Dim Info2()
ReDim Info2(SpaltenAnzahl) '... entsprechend dimensioniertes Array erstellen  

Set D = CreateObject("Scripting.Dictionary")  
Zeile = AbZeile 'in AbZeile beginnen  

With Worksheets(Quelltabelle)
    Schrift = .Cells(Zeile, ErsteSpalte) 'Schriftnamen auslesen  
    Do While Schrift <> "" 'Schleife, solange es in ErsteSpalte Schriftnamen gibt  
    
        If D.Exists(Schrift) Then 'Falls für die Schrift der aktuellen Zeile bereits ein Eintrag vorhanden ist, ...  
            Info1 = D.Item(Schrift) '... diesen auslesen und die einzelnen Felder in das Array Info1 schreiben  
            For i = 0 To SpaltenAnzahl '### hatte gefehlt ###  
                If InStr(1, Info1(i), .Cells(Zeile, Spalten(i)), vbTextCompare) = 0 Then '... und nur noch nicht enthaltene Informationen ...  
                    Info2(i) = Info1(i) & ", " & .Cells(Zeile, Spalten(i)) '... durch Komma und Leerzeichen getrennt, an die vorhandenen Informationen anfügen  
                Else
                    Info2(i) = Info1(i)
                End If
            Next '### hatte gefehlt ###  
        Else 'Schrift noch nicht in Dictionary, ...  
            For i = 0 To SpaltenAnzahl
                Info2(i) = .Cells(Zeile, Spalten(i)) ' ... daher Einzelinformationen (ohne Anfügen) einfach eintragen  
            Next
        End If
    
        D.Item(Schrift) = Info2 'Array in Dictionary schreiben  
    
        Zeile = Zeile + 1 'nächste Zeile  
        Schrift = .Cells(Zeile, ErsteSpalte) 'Schriftnamem auslesen  
    Loop
End With

Zeile = AbZeile 'in Abzeile mit dem Eintragen beginnen  
With Worksheets(ZielTabelle)
    For Each Schrift In D.Keys 'für jede Schrift eine Zeile erzeugen, ...  
        .Cells(Zeile, ErsteSpalte) = Schrift '... in die erste Spalte den Schriftnamen und ...  
        Info1 = D.Item(Schrift) '... nach dem Auslesen der Informationen und Aufteilung in ein Array ...  
        For i = 0 To SpaltenAnzahl
            .Cells(Zeile, Spalten(i)) = Info1(i) '... in jede der vorgegebenen Spalten die zusammengefassten Informationen eintragen  
        Next
        Zeile = Zeile + 1
    Next
    For i = 0 To SpaltenAnzahl
        Columns(Spalten(i)).EntireColumn.AutoFit 'optimale Spaltenbreite einstellen  
    Next
End With
End Sub

Die Angaben in den Zeilen 2 bis 6 sind natürlich anzupassen (wobei ich zum Testen Dein Beispiel incl Überschriften einfach in "Tabelle1!A1:F6" eingefügt habe).

Zu ergänzen wären noch das Löschen der Zieltabelle (nur relevant, wenn sich die Schriftenanzahl vermindern sollte, da ansonsten ohnehin überschrieben wird), das Übernehmen der Überschriften sowie ev das Sortieren der Schriften ...

Grüße
bastla

[Edit] Zeilen 21 - 23 (alt) durch 21 - 25 (neu) ersetzt, um nur neue Informationen hinzuzufügen [/Edit]

[Edit2] Jetzige Zeilen 21 und 27 ergänzt [/Edit2]

Hallo Bastla,

Du bist genial!

Nach Deiner Änderung kommt jedoch in der neuen Zeile 21 die Fehlermeldung: info1(i) <Index außerhalb des gültigen Bereichs>
In Deiner ursprünglichen Version war das nicht so.

Ich habe mich bei meiner "Beispieltabelle" bzw. Frage nicht sorgfältig genug ausgedrückt (schäm).
Die Tabelle, deren Inhalte ich zusammenfügen möchte, wird definiert per:

With Range("A1:P1")
.Value = Array("Lfd.-Nr.", "Blattname", "Veröffentlichungs-Nummer", "Anmelde-Datum", _
"Veröffentlichungs-Datum", "IPC-Hauptklasse", "Erfinder", "Anmelder", "Titel", _
"Prüfstoff-IPC", "PDF", "esp@cenet", "Thema", "Bemerkung", "Beurteilung", "irrelevant")
End With

Für diese Tabellenform wäre
ErsteSpalte = "C" ("Veröffentlichungs-Nummer") und
Spalten = Array("M", "N", "O") (für "Thema", "Bemerkung", "Beurteilung")

Wie wäre es denn möglich, dass Spalten D (Anmelde-Datum) bis L(esp@cenet) übernommen werden (deren Inhalte zum Eintrag in "ErsteSpalte" gehören)?

Herzliche Grüße
Fusselfrei

Hallo Fusselfrei!

Sorry - da war ich offensichtlich schon etwas zu müde im Kopf ...

Es fehlt natürlich die Schleife umd die Zeilen 21 - 25 herum - ich trage das oben nach ...

Zu den Werten in den Spalten D bis L: Falls diese verlässlich redundant sind (also in allen Zeilen mit dem gleichen Wert in Spalte C auch diese Spalten die gleichen Werte aufweisen), könnten alle Spalte per "Join()" zu einem String zusammgefasst werden und als "Key" im Dictionary dienen; es würde in diesem Fall ein Trennzeichen (zB "§") benötigt, das in keinem Feld vorkommt.

Ich warte diesbezüglich aber erst einmal Deine Rückmeldung ab ...

Grüße
bastla

Jetzt klappt es prima!

Ja, es ist so wie Du es sagtest, zu genau einem Eintrag in "C" gehören in den Spalten D bis L eindeutige Werte, z.B

zu C: "DE102004025292A1" gehören die eindeutigen Werte in
D: "15.12.2005"
E: "B62K 27/12"
F: "[DE] Fahrradgespann [EN] Bicycle and sidecar combination used as public ... "
G: "DE_1020040025292_A1"
H: "Beschreibung"
I: "Kupplung"
J: "Beiwagenkopplung - hoffentlich haben die Erfinder die Probefahrt unbeschadet überstanden"
K: "0"

Ein "§" kommt in keinem der Felder vor.

Grüße
Fusselfrei

Hallo Fusselfrei!

Neuer Versuch:

Sub Zusammenfassen_Neu()
ZielTabelle = "Tabelle2"  
Quelltabelle = "Tabelle1"  
AbZeile = 2 'Erste zu lesende / schreibende Zeile der Tabellen  
ErsteSpalte = 3 'Nr. der Spalte "Schrift" = Beginn der "Key"-Daten = Spalte "C"  
LetzteSpalte = 12 'Spalten-Nr. für Ende der "Key"-Daten = Spalte "L"  
Delim = "§" 'Trennzeichen (darf in den Daten der Spalten von "ErsteSpalte" bis "LetzteSpalte" nicht enthalten  sein  
Spalten = Array("M", "N", "O") 'Spalten mit den zusammenzufassenden Einträgen  

SpaltenAnzahl = UBound(Spalten) 'Anzahl der Spalten ermitteln und ...  
Dim Info2()
ReDim Info2(SpaltenAnzahl) '... entsprechend dimensioniertes Array erstellen  

Set D = CreateObject("Scripting.Dictionary")  
Zeile = AbZeile 'in AbZeile beginnen  

With Worksheets(Quelltabelle)
    Schrift = .Cells(Zeile, ErsteSpalte) 'Schriftnamen auslesen  
    Do While Schrift <> "" 'Schleife, solange es in ErsteSpalte Schriftnamen gibt  
        For i = ErsteSpalte + 1 To LetzteSpalte 'Key aus allen Feldinhalten von "ErsteSpalte" bis "LetzteSpalte" ...  
            Schrift = Schrift & Delim & .Cells(Zeile, i) ... durch "Delim" getrennt als String zusammensetzen  
        Next
        If D.Exists(Schrift) Then 'Falls für die Schrift der aktuellen Zeile bereits ein Eintrag vorhanden ist, ...  
            Info1 = D.Item(Schrift) '... diesen auslesen und die einzelnen Felder in das Array Info1 schreiben  
            For i = 0 To SpaltenAnzahl
                If InStr(1, Info1(i), .Cells(Zeile, Spalten(i)), vbTextCompare) = 0 Then '... und nur noch nicht enthaltene Informationen ...  
                    Info2(i) = Info1(i) & ", " & .Cells(Zeile, Spalten(i)) '... durch Komma und Leerzeichen getrennt, an die vorhandenen Informationen anfügen  
                Else
                    Info2(i) = Info1(i)
                End If
            Next
        Else 'Schrift noch nicht in Dictionary, ...  
            For i = 0 To SpaltenAnzahl
                Info2(i) = .Cells(Zeile, Spalten(i)) ' ... daher Einzelinformationen (ohne Anfügen) einfach eintragen  
            Next
        End If
        
        D.Item(Schrift) = Info2 'Array in Dictionary schreiben  
    
        Zeile = Zeile + 1 'nächste Zeile  
        Schrift = .Cells(Zeile, ErsteSpalte) 'Schriftnamem auslesen  
    Loop
End With

Zeile = AbZeile 'in Abzeile mit dem Eintragen beginnen  
With Worksheets(ZielTabelle)
    For Each Schrift In D.Keys 'für jede Schrift eine Zeile erzeugen, ...  
        SchriftInfo = Split(Schrift, Delim) 'Zusammengesetzten Key in Array umwandeln ...  
        .Cells(Zeile, ErsteSpalte).Resize(1, UBound(SchriftInfo) + 1) = SchriftInfo '... und ab "ErsteSpalte" in die Spalte eintragen sowie  ...  
        Info1 = D.Item(Schrift) '... nach dem Auslesen der Informationen und Aufteilung in ein Array ...  
        For i = 0 To SpaltenAnzahl
            .Cells(Zeile, Spalten(i)) = Info1(i) '... in jede der vorgegebenen Spalten die zusammengefassten Informationen eintragen  
        Next
        Zeile = Zeile + 1
    Next
    For i = 0 To SpaltenAnzahl
        Columns(Spalten(i)).EntireColumn.AutoFit 'optimale Spaltenbreite einstellen  
    Next
End With
End Sub

Die Angabe von "ErsteSpalte" und "LetzteSpalte" (es wird vorausgesetzt., dass es sich um einen zusammenhängenden Bereich handelt) habe ich der Einfachheit halber nicht mit Buchstaben, sondern mit Spaltennummern vorgenommen - lässt sich aber bei Bedarf noch "behübschen" ...

Grüße
bastla