Top-Themen

AppleEntwicklungHardwareInternetLinuxMicrosoftMultimediaNetzwerkeOff TopicSicherheitSonstige SystemeVirtualisierungWeiterbildungZusammenarbeit

Aktuelle Themen

Administrator.de FeedbackApache ServerAppleAssemblerAudioAusbildungAuslandBackupBasicBatch & ShellBenchmarksBibliotheken & ToolkitsBlogsCloud-DiensteClusterCMSCPU, RAM, MainboardsCSSC und C++DatenbankenDatenschutzDebianDigitiales FernsehenDNSDrucker und ScannerDSL, VDSLE-BooksE-BusinessE-MailEntwicklungErkennung und -AbwehrExchange ServerFestplatten, SSD, RaidFirewallFlatratesGoogle AndroidGrafikGrafikkarten & MonitoreGroupwareHardwareHosting & HousingHTMLHumor (lol)Hyper-VIconsIDE & EditorenInformationsdiensteInstallationInstant MessagingInternetInternet DomäneniOSISDN & AnaloganschlüsseiTunesJavaJavaScriptKiXtartKVMLAN, WAN, WirelessLinuxLinux DesktopLinux NetzwerkLinux ToolsLinux UserverwaltungLizenzierungMac OS XMicrosoftMicrosoft OfficeMikroTik RouterOSMonitoringMultimediaMultimedia & ZubehörNetzwerkeNetzwerkgrundlagenNetzwerkmanagementNetzwerkprotokolleNotebook & ZubehörNovell NetwareOff TopicOpenOffice, LibreOfficeOutlook & MailPapierkorbPascal und DelphiPeripheriegerätePerlPHPPythonRechtliche FragenRedHat, CentOS, FedoraRouter & RoutingSambaSAN, NAS, DASSchriftartenSchulung & TrainingSEOServerServer-HardwareSicherheitSicherheits-ToolsSicherheitsgrundlagenSolarisSonstige SystemeSoziale NetzwerkeSpeicherkartenStudentenjobs & PraktikumSuche ProjektpartnerSuseSwitche und HubsTipps & TricksTK-Netze & GeräteUbuntuUMTS, EDGE & GPRSUtilitiesVB for ApplicationsVerschlüsselung & ZertifikateVideo & StreamingViren und TrojanerVirtualisierungVisual StudioVmwareVoice over IPWebbrowserWebentwicklungWeiterbildungWindows 7Windows 8Windows 10Windows InstallationWindows MobileWindows NetzwerkWindows ServerWindows SystemdateienWindows ToolsWindows UpdateWindows UserverwaltungWindows VistaWindows XPXenserverXMLZusammenarbeit
GELÖST

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

Frage Entwicklung VB for Applications

Mitglied: Fusselfrei

Fusselfrei (Level 1) - Jetzt verbinden

12.06.2010 um 22:24 Uhr, 15348 Aufrufe, 7 Kommentare

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 BemerkungBeurteilung...
D1 ... Thema1 Bemerkung 1 a...
D2 ... Thema2 Bemerkung 2 b ...
D3 ... Thema3 Bemerkung 1 c ...
D2 ... Thema3 Bemerkung 3 d...
D1 ... Thema1Bemerkung 4 e...

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

Beispiel nachher:
Druckschrift...Thema BemerkungBeurteilung...
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
Mitglied: bastla
13.06.2010 um 01:35 Uhr
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:
01.
Sub Zusammenfassen() 
02.
ZielTabelle = "Tabelle2" 
03.
Quelltabelle = "Tabelle1" 
04.
AbZeile = 2 'Erste zu lesende / schreibende Zeile der Tabellen 
05.
ErsteSpalte = "A" 'Spalte "Schrift" 
06.
Spalten = Array("C", "D", "E") 'Spalten mit den zusammenzufassenden Einträgen 
07.
 
08.
SpaltenAnzahl = UBound(Spalten) 'Anzahl der Spalten ermitteln und ... 
09.
Dim Info2() 
10.
ReDim Info2(SpaltenAnzahl) '... entsprechend dimensioniertes Array erstellen 
11.
 
12.
Set D = CreateObject("Scripting.Dictionary") 
13.
Zeile = AbZeile 'in AbZeile beginnen 
14.
 
15.
With Worksheets(Quelltabelle) 
16.
    Schrift = .Cells(Zeile, ErsteSpalte) 'Schriftnamen auslesen 
17.
    Do While Schrift <> "" 'Schleife, solange es in ErsteSpalte Schriftnamen gibt 
18.
     
19.
        If D.Exists(Schrift) Then 'Falls für die Schrift der aktuellen Zeile bereits ein Eintrag vorhanden ist, ... 
20.
            Info1 = D.Item(Schrift) '... diesen auslesen und die einzelnen Felder in das Array Info1 schreiben 
21.
            For i = 0 To SpaltenAnzahl '### hatte gefehlt ### 
22.
                If InStr(1, Info1(i), .Cells(Zeile, Spalten(i)), vbTextCompare) = 0 Then '... und nur noch nicht enthaltene Informationen ... 
23.
                    Info2(i) = Info1(i) & ", " & .Cells(Zeile, Spalten(i)) '... durch Komma und Leerzeichen getrennt, an die vorhandenen Informationen anfügen 
24.
                Else 
25.
                    Info2(i) = Info1(i) 
26.
                End If 
27.
            Next '### hatte gefehlt ### 
28.
        Else 'Schrift noch nicht in Dictionary, ... 
29.
            For i = 0 To SpaltenAnzahl 
30.
                Info2(i) = .Cells(Zeile, Spalten(i)) ' ... daher Einzelinformationen (ohne Anfügen) einfach eintragen 
31.
            Next 
32.
        End If 
33.
     
34.
        D.Item(Schrift) = Info2 'Array in Dictionary schreiben 
35.
     
36.
        Zeile = Zeile + 1 'nächste Zeile 
37.
        Schrift = .Cells(Zeile, ErsteSpalte) 'Schriftnamem auslesen 
38.
    Loop 
39.
End With 
40.
 
41.
Zeile = AbZeile 'in Abzeile mit dem Eintragen beginnen 
42.
With Worksheets(ZielTabelle) 
43.
    For Each Schrift In D.Keys 'für jede Schrift eine Zeile erzeugen, ... 
44.
        .Cells(Zeile, ErsteSpalte) = Schrift '... in die erste Spalte den Schriftnamen und ... 
45.
        Info1 = D.Item(Schrift) '... nach dem Auslesen der Informationen und Aufteilung in ein Array ... 
46.
        For i = 0 To SpaltenAnzahl 
47.
            .Cells(Zeile, Spalten(i)) = Info1(i) '... in jede der vorgegebenen Spalten die zusammengefassten Informationen eintragen 
48.
        Next 
49.
        Zeile = Zeile + 1 
50.
    Next 
51.
    For i = 0 To SpaltenAnzahl 
52.
        Columns(Spalten(i)).EntireColumn.AutoFit 'optimale Spaltenbreite einstellen 
53.
    Next 
54.
End With 
55.
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]
Bitte warten ..
Mitglied: Fusselfrei
13.06.2010 um 03:36 Uhr
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
Bitte warten ..
Mitglied: bastla
13.06.2010, aktualisiert 12.11.2012
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
Bitte warten ..
Mitglied: Fusselfrei
13.06.2010 um 23:02 Uhr
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
Bitte warten ..
Mitglied: bastla
14.06.2010 um 01:37 Uhr
Hallo Fusselfrei!

Neuer Versuch:
01.
Sub Zusammenfassen_Neu() 
02.
ZielTabelle = "Tabelle2" 
03.
Quelltabelle = "Tabelle1" 
04.
AbZeile = 2 'Erste zu lesende / schreibende Zeile der Tabellen 
05.
ErsteSpalte = 3 'Nr. der Spalte "Schrift" = Beginn der "Key"-Daten = Spalte "C" 
06.
LetzteSpalte = 12 'Spalten-Nr. für Ende der "Key"-Daten = Spalte "L" 
07.
Delim = "§" 'Trennzeichen (darf in den Daten der Spalten von "ErsteSpalte" bis "LetzteSpalte" nicht enthalten  sein 
08.
Spalten = Array("M", "N", "O") 'Spalten mit den zusammenzufassenden Einträgen 
09.
 
10.
SpaltenAnzahl = UBound(Spalten) 'Anzahl der Spalten ermitteln und ... 
11.
Dim Info2() 
12.
ReDim Info2(SpaltenAnzahl) '... entsprechend dimensioniertes Array erstellen 
13.
 
14.
Set D = CreateObject("Scripting.Dictionary") 
15.
Zeile = AbZeile 'in AbZeile beginnen 
16.
 
17.
With Worksheets(Quelltabelle) 
18.
    Schrift = .Cells(Zeile, ErsteSpalte) 'Schriftnamen auslesen 
19.
    Do While Schrift <> "" 'Schleife, solange es in ErsteSpalte Schriftnamen gibt 
20.
        For i = ErsteSpalte + 1 To LetzteSpalte 'Key aus allen Feldinhalten von "ErsteSpalte" bis "LetzteSpalte" ... 
21.
            Schrift = Schrift & Delim & .Cells(Zeile, i) ... durch "Delim" getrennt als String zusammensetzen 
22.
        Next 
23.
        If D.Exists(Schrift) Then 'Falls für die Schrift der aktuellen Zeile bereits ein Eintrag vorhanden ist, ... 
24.
            Info1 = D.Item(Schrift) '... diesen auslesen und die einzelnen Felder in das Array Info1 schreiben 
25.
            For i = 0 To SpaltenAnzahl 
26.
                If InStr(1, Info1(i), .Cells(Zeile, Spalten(i)), vbTextCompare) = 0 Then '... und nur noch nicht enthaltene Informationen ... 
27.
                    Info2(i) = Info1(i) & ", " & .Cells(Zeile, Spalten(i)) '... durch Komma und Leerzeichen getrennt, an die vorhandenen Informationen anfügen 
28.
                Else 
29.
                    Info2(i) = Info1(i) 
30.
                End If 
31.
            Next 
32.
        Else 'Schrift noch nicht in Dictionary, ... 
33.
            For i = 0 To SpaltenAnzahl 
34.
                Info2(i) = .Cells(Zeile, Spalten(i)) ' ... daher Einzelinformationen (ohne Anfügen) einfach eintragen 
35.
            Next 
36.
        End If 
37.
         
38.
        D.Item(Schrift) = Info2 'Array in Dictionary schreiben 
39.
     
40.
        Zeile = Zeile + 1 'nächste Zeile 
41.
        Schrift = .Cells(Zeile, ErsteSpalte) 'Schriftnamem auslesen 
42.
    Loop 
43.
End With 
44.
 
45.
Zeile = AbZeile 'in Abzeile mit dem Eintragen beginnen 
46.
With Worksheets(ZielTabelle) 
47.
    For Each Schrift In D.Keys 'für jede Schrift eine Zeile erzeugen, ... 
48.
        SchriftInfo = Split(Schrift, Delim) 'Zusammengesetzten Key in Array umwandeln ... 
49.
        .Cells(Zeile, ErsteSpalte).Resize(1, UBound(SchriftInfo) + 1) = SchriftInfo '... und ab "ErsteSpalte" in die Spalte eintragen sowie  ... 
50.
        Info1 = D.Item(Schrift) '... nach dem Auslesen der Informationen und Aufteilung in ein Array ... 
51.
        For i = 0 To SpaltenAnzahl 
52.
            .Cells(Zeile, Spalten(i)) = Info1(i) '... in jede der vorgegebenen Spalten die zusammengefassten Informationen eintragen 
53.
        Next 
54.
        Zeile = Zeile + 1 
55.
    Next 
56.
    For i = 0 To SpaltenAnzahl 
57.
        Columns(Spalten(i)).EntireColumn.AutoFit 'optimale Spaltenbreite einstellen 
58.
    Next 
59.
End With 
60.
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
Bitte warten ..
Mitglied: Fusselfrei
14.06.2010 um 23:43 Uhr
Hallo bastla,

vielen Dank für Deine großartige Hilfe!

Es klappt perfekt!

Herzliche Grüße
Fusselfrei
Bitte warten ..
Neuester Wissensbeitrag
Humor (lol)

Linkliste für Adventskalender

(3)

Information von nikoatit zum Thema Humor (lol) ...

Ähnliche Inhalte
Microsoft Office
gelöst Verschieben von Zellinformation in andere Spalte (per VBA) excel 2010 (5)

Frage von thomas1972 zum Thema Microsoft Office ...

VB for Applications
Bilder vom LDAP in VBA - Excel (3)

Frage von Roadrunner777 zum Thema VB for Applications ...

VB for Applications
gelöst VBA Excel Recordset - Abfrage auf SQL-Server (4)

Frage von Aximand zum Thema VB for Applications ...

VB for Applications
gelöst Excel VBA Werte von 2 verschiedenen Sheets vergleichen und aktualisieren (4)

Frage von drimrim zum Thema VB for Applications ...

Heiß diskutierte Inhalte
Exchange Server
gelöst Exchange 2010 Berechtigungen wiederherstellen (20)

Frage von semperf1delis zum Thema Exchange Server ...

Windows Server
DHCP Server switchen (20)

Frage von M.Marz zum Thema Windows Server ...

Hardware
gelöst Negative Erfahrungen LAN-Karten (19)

Frage von MegaGiga zum Thema Hardware ...

Exchange Server
DNS Einstellung - zwei feste IPs für Mailserver (15)

Frage von ivan0s zum Thema Exchange Server ...