Top-Themen

Aktuelle Themen (A bis Z)

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

Mitglied: Fusselfrei

Fusselfrei (Level 1) - Jetzt verbinden

12.06.2010 um 22:24 Uhr, 16074 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 ..
Ähnliche Inhalte
Microsoft Office

VBA Excel Automatisch Filtern und Zeilen vergleichen

Frage von mcflyjuleMicrosoft Office

Hallo liebe Community, ich bin neu hier und habe leider (noch) keine Kenntnisse in VBA Hab das bisher immer ...

Microsoft Office

Zeilen in Excel auf Gleichheit vergleichen

gelöst Frage von abuelitoMicrosoft Office6 Kommentare

Hallo an Alle, ich habe folgendes Problem und würde mich freuen, wenn ihr mir helfen könnte (benötige eine VBA ...

VB for Applications

Inhalte vergleichen - Excel VBA

gelöst Frage von Acht85VB for Applications10 Kommentare

Hallo lieber User, ich habe ein kurze Frage und würde mich sehr freuen, wenn ihr mir damit weiterhelfen könnt. ...

Batch & Shell

Erste Zeile einer Excel Datei vergleichen

gelöst Frage von Memo66Batch & Shell8 Kommentare

Hallo zusammen, ich habe folgendes Szenario. Ich bekomme täglich eine .csv Datei zugeschickt. In der Datei sind nun in ...

Neue Wissensbeiträge
Vmware
VMware Update für den ESXi 5.5 verfügbar
Information von sabines vor 4 StundenVmware

Nach dem ganzen Hickhack um Update mit Microcode Anpassungen und Rückzug, gibt es nun für den ESXi 5.5 ein ...

CPU, RAM, Mainboards

Meltdown und Spectre: Intel zieht Microcode-Updates für Prozessoren zurück

Information von keine-ahnung vor 8 StundenCPU, RAM, Mainboards4 Kommentare

Moin, extrem lutztig. Nur gut, dass ich noch nicht beim Probanden-Bingo mitgemacht habe :-) LG, Thomas

Router & Routing
PfSense als Addon auf QNAP
Information von magicteddy vor 22 StundenRouter & Routing4 Kommentare

Moin, für Spielereien eine ganz nette Idee aber ich fürchte das soetwas auch als echte Firewall genutzt wird: In ...

Datenschutz

Teamviewer kommt für IoT-Geräte wie den Raspberry Pi

Information von magicteddy vor 1 TagDatenschutz1 Kommentar

Moin, jetzt werden IoT Geräte endgültig zur Wanze? Anscheinend kann man auf einem Dashboard seine Geräte visualisieren Ich stelle ...

Heiß diskutierte Inhalte
Netzwerkmanagement
Preis für Wartungsvertrag ok?
gelöst Frage von a-za-zNetzwerkmanagement26 Kommentare

Hallo! Mal ne Frage, weil ich mich mit dem akzeptablen Preis für einen Reaktionszeitvertrag nicht auskenne. Meine Firma hat ...

Windows Server
TEMP-Profile
gelöst Frage von Forseti2003Windows Server21 Kommentare

Guten Morgen, wer kennt sie nicht, die lieben Temporären Benutzerprofile, vorallem immer dann, wenn man sie am wenigsten braucht. ...

Multimedia & Zubehör
Welches Tablet für die Verkäufer?
Frage von Hendrik2586Multimedia & Zubehör15 Kommentare

Guten Morgen meine Lieben, vielleicht könnt ihr mir ja helfen. Es geht um unsere Außendienstmitarbeiter /Verkäufer. Sie sollen demnächst ...

Windows Netzwerk
Ist ein Portforwarding auf einen PC ohne lauschendes Programm ein (großes) Sicherheitsproblem?
Frage von PluwimWindows Netzwerk13 Kommentare

Hallo zusammen, zur Fernwartung eines Rechners an einem anderen Ort nutze ich VNC. Da dieser Rechner einfach nur eine ...