Makro zum Zusammenführen von Duplikaten

[Thor_sten]

Hallo liebes Forum!

Leider bin ich mit Makros nicht sonderlich vertraut. Daher stellt das nachfolgend geschilderte Problem eine unlösbare Aufgabe für mich dar. Vielleicht ist es aber für einen Spezi unter euch nur eine Kleinigkeit? Oder Jemand kann mir zumindest Hinweise geben, wie ich meiner Lösung näher komme?

Im Rahmen einer Abschlussarbeit stehe ich vor fogendem Problem:

Ich muss mehrere Excelsheets zusammenkopieren. Der Aufbau der Tabellen ist immer identisch. Dabei ist Spalte (A) immer eine Nummer, Spalte (B) eine Bennenung und Spalten (C-N) stellen den Inhalt dar.
Dabei treten Duplikate auf. So ist es möglich, dass die gleiche Nummer (A) mit der dazugehörigen Benennung (B) in verschiedenen Sheets vorkommen und dementsprechend mehrfach vorhanden sind.
Das Problem ist, dass zwar Nummer (A) und Benennung (B) identisch sind jedoch die Inhalte (C-N) sich unterscheiden.
Die Lösung sollte folgendermaßen aussehen:

Doppelte Einträge sollen so zusammengeführt werden, dass Nummer (A) und Benennung (B) nur einmal vorkommen. Die Inhalte (C-N) sollen untereinander aufgelistet werden.

Zur Veranschaulichung hier nachfolgend eine Beispieltabelle:

A____________B__________C______________D_____________E

1.1.1.1_______eins_______AAAA___________RRRR__________11111
1.1.1.2_______zwei_______BBBB__________SSSSV__________22222
1.1.1.3_______drei_______CCCC___________TTTT__________33333
1.1.1.4_______vier_______DDDD__________UUUU__________44444
1.1.1.2_______zwei______ABABAB_________SXSXSX_________232323
1.1.1.4_______vier_______ADADAD_______UXUXUX_________242424
1.1.1.2_______zwei______ACACAC________SYSYSY_________323232
1.1.1.4_______vier_______AEAEAE________UYUYUY________343434

Die Einträge mit den Nummern (A) 1.1.1.2 und 1.1.1.4 kommen mehrfach vor. Sie haben jeweils die gleiche Benennung (B). Nummer und Benennung sind in allen Sheets zusammengehörend, so wird der Eintrag 1.1.1.1 immer die Benennung "eins" haben, die 1.1.1.3 wird immer die Benennung "drei" haben usw. Es unterscheiden sich lediglich die Inhalte aus C-N.


Sortiert man die Tabelle nach Nummern (A) sieht die Tabelle folgendermaßen aus:

A______________B____________C____________D______________E

1.1.1.1________eins__________AAAA_________RRRR__________11111
1.1.1.2________zwei__________BBBB_________SSSS___________22222
1.1.1.2________zwei__________ABABAB_______SXSXSX________232323
1.1.1.2________zwei__________ACACAC______SYSYSY_________323232
1.1.1.3________drei__________CCCC_________TTTT__________33333
1.1.1.4________vier__________DDDD________UUUU__________44444
1.1.1.4________vier__________ADADAD______UXUXUX________242424
1.1.1.4________vier__________AEAEAE_______UYUYUY________343434

Deutlich zu erkennen ist, dass die Nummern (A) und die Benennungen (B) unnötigerweise mehrfach vorkommen.


Die Lösung sollte daher folgendermaßen aussehen:

A_____________B____________C_____________D_____________E

1.1.1.1________eins_________AAAA___________RRRR________11111
1.1.1.2________zwei_________BBBB___________SSSS_________22222
_________________________ABABAB_________SXSXSX_______232323
_________________________ACACAC_________SYSYSY_______323232
1.1.1.3________drei_________CCCC___________TTTT_________33333
1.1.1.4________vier_________DDDD__________UUUU________44444
_________________________ADADAD_______UXUXUX________242424
_________________________AEAEAE________UYUYUY________343434

Bestenfalls, um die Übersichtlichkeit zu steigern, sollte jede zweite Zeile in der eine Nummer (A) vorkommt mit einer Farbe hinterlegt werden.

Ich bin wirklich auf eure Hilfe angewiesen und freue mich über jede hilfreiche Antwort.

[steve1da]

Hola,

verlinkst du bitte deine Fragen in den verschiedenen Foren untereinander?
Danke.

Gruß,
steve1da

[steve1da]

Hola,

scheinbar nicht...

http://www.office-fragen.de/index.php/to...292.0.html

Gruß,
steve1da

[Gast 123]

Hallo,

allo,

anbei ein vollstaendiger Code für dieses Problem, bestehend aus drei Teilen.  Die Makros müssen in der richtigen Reihenfolge ausgeführt werden.  
Zuerst "Tabellen kopieren", dann "doppelte löschen".  Das Sortierprogramm wird von "doppelte_Löschen" mit aufgerufen!    

Es müssen aber noch manuelle Arbeiten durchgeführt werden!  Überall wo:  -Worksheets("Ziel")- steht muss der Name der richtigen Zieltabelle eingesetzt werden.  Im ersten Makro müssen noch die Namen der zu kopierenden Tabellen angegeben werden, s. Sht = "Tabelle1".  Ob es zwei, drei, vier oder mehr sind ist egal.  Beim erweitern immer  -GoSub kopieren- mit angeben!  Wie im Beispiel.

Würde mich freuen wenn mein Lösungsvorschlag klappt.

mfg Gast 123

Code:

Option Explicit     '3.8.2017   Gast 123   Clever Forum
Dim lzSo As Long, Sht As String

'Modul zum Tabellen kopieren und doppelte Löschen

Sub Tabellen_kopieren()
Dim ZTB As Worksheet, Sht As String
Dim lzCp As Long, lzZt As Long
Set ZTB = Worksheets("Ziel")    '** Name der Ziel Tabelle
   
ZTB.Cells.Delete  'Ziel Tabelle löschen

'Unterprogramm Aufruf zum kopieren
'Copy Tabellen Namen einzeln angeben  'beliebig erweiterbar:
Sht = "Tabelle1":  GoSub kopieren   'Name der Copy Tabellen
Sht = "Tabelle2":  GoSub kopieren
Sht = "Tabelle3":  GoSub kopieren
Exit Sub

kopieren:   'Programm zum kopieren über Sht
With Worksheets(Sht)
   'LastZell Copy + LastZell Ziel Tabelle ermitteln
   lzCp = .Cells(Rows.Count, 1).End(xlUp).Row
   lzZt = ZTB.Cells(Rows.Count, 1).End(xlUp).Row
   If lzZt > 1 Then lzZt = lzZt + 1
   
   .Range("A1:N" & lzCp).Copy
   ZTB.Range("A" & lzZt).PasteSpecial xlPasteAll
   Application.CutCopyMode = False
   Return
End With
End Sub


Sub doppelte_löschen()
Dim AC As Range, lzZt As Long
Dim flg As Variant, s As Integer
With Worksheets("Ziel")    '** Name der Ziel Tabelle
  Sht = .Name      'Name zum Sortieren
  Call Sortieren   'Aktiven Bereich Sortieren

  lzZt = .Cells(Rows.Count, 1).End(xlUp).Row
  'Schleife für doppelte Werte löschen
  For Each AC In Range("A1:A" & lzZt)
    'Spalte A + B Werte vergleichen
    If AC.Offset(1, 0) = AC.Value Then
    If AC.Offset(1, 1) = AC.Offset(0, 1) Then
      flg = Empty
      For s = 3 To 14  'Spalte C-N vergleichen
         If AC.Offset(0, s) <> AC.Offset(1, s) Then flg = s: Exit For
      Next s
      'Bei Gleichheit AC Spalte löschen
      If flg = Empty Then AC.Resize(1, 14) = Empty
    End If
    End If
  Next AC

  Call Sortieren   'Aktiven Bereich Sortieren
End With
End Sub


Sub Sortieren()
   lzSo = Cells(Rows.Count, 1).End(xlUp).Row
   ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
   ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A1"), _
       SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
   ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("B1"), _
       SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
   With ActiveWorkbook.ActiveSheet.Sort
       .SetRange Range("A1:N" & lzSo)
       .Header = xlGuess
       .MatchCase = False
       .Orientation = xlTopToBottom
       .SortMethod = xlPinYin
       .Apply
   End With
End Sub

[RPP63]

Moin!
Zunächst:
Dies ist eine Alternative und stellt keine Kritik an der Arbeit von Gast dar!

Zum Thema:
@Thorsten:
Warum willst Du Dir eine korrekte Excel-Liste mutwillig zerstören?
Wenn Du die Dubletten löscht, funktioniert z.B. ein nachträgliches Sortieren der Liste nicht resp. wirft ein völlig falsches Ergebnis raus!!
Mein Favorit:
Mache sie einfach unsichtbar!
Dies kann man mit reinen Excel-Mitteln, also ohne VBA erreichen.
Siehe dazu meine Antwort in diesem Thread [klick]
Ein nachträgliches Erweitern und Neusortieren der Liste ist dann problemlos möglich.
Auch der zweite Wunsch der abwechselnden Hintergrundfabe der Dubletten ließe sich mit einer bedingten Formatierung realisieren.
Besser und einfacher ist es jedoch, die Tabelle mittels Strg+t in ein Listobjekt umzuwandeln.

	A	B	C	D	E
1	A	B	C	D	E
2	1.1.1.1	eins	AAAA	RRRR	11111
3	1.1.1.2	zwei	BBBB	SSSS	22222
4			ABABAB	SXSXSX	232323
5			ACACAC	SYSYSY	323232
6	1.1.1.3	drei	CCCC	TTTT	33333
7	1.1.1.4	vier	DDDD	UUUU	44444
8			ADADAD	UXUXUX	242424
9			AEAEAE	UYUYUY	343434

Zelle	Format	Wert
A2	;;;	1.1.1.1
B2	;;;	eins

Zelle	bedingte Formatierung...	Format
A2	1: =A1<>A2	abc
B2	1: =B1<>B2	abc

Gruß Ralf

[GMG-CC]

@Ralf:
Genau diese Lösung hatte er schon im Nachbarforum, dazu auch noch eine PT-Lösung.
Aber was willst dun schon von ignoranten Crosspostern ohne Querverweis erwarten ...

[Thor_sten]

Hallo zusammen!

Vielen Dank für eure Lösungen RPP63 und Gast 123. Ich habe das Problem jetzt gelöst bekommen.

@GMG-CC: Offensichtlich hast du eine ziemlich kurze Zündschnür um hier so aufzutreten. Ein Hinweis hätte es auch getan, anstatt direkt so ausfallend zu werden und mich als ignorant dazustellen.


Beste Grüße

Thor_sten

[GMG-CC]

Wenn ich ausfallend werde, sieht das noch ganz anders aus.
Aber du wirst dich mit deinen Regel-Widrigkeiten nicht mehr über mich ärgern müssen, denn deine Beiträge werden mir ab sofort nicht mehr angezeigt.