✔ Makro zusammenführen von Duplikaten

rince1984

rince1984

Mitglied
Hallo liebe Community,

ich bin auf der Suche nach einem Excel-Makro das anhand einer Spalte Duplikate findet und die Werte der Duplikatzeilen in der ersten Duplikatzeile zusammenführt (in neue Spalten).
Ich benutze Excel 2010.
Die Anzahl der Duplikate kann varieren, genauso die Anzahl der Gesamtspalten.

Als Beispiel ist folgender Tabellenaufbau gegeben:

Kundenummer | Geburtsdatum | Bemerkung
1234 | 10.08.1984 | Lorem ipsum
1234 | 23.07.1954 | dolor sit amet
1234 | 03.07.1982 | consetetur
1234 | 17.02.1985 | sadipscing
1234 | 28.08.2013 | elitr
5475 | 01.01.2011 | Lorem ipsum
63124 | 04.04.1964 | dolor sit amet
63124 | 05.09.2000 | consetetur
9999 | 06.05.2010 | sadipscing

Gegeben.JPG


Anforderung:
Der Anwender soll in Excel über eine InputBox angeben können welche Spalte nach Duplikaten durchsucht werden soll (in diesem Beispiel wäre Spalte A die richtige Wahl).

Wenn in der ausgewählten Spalte Duplikate gefunden wurden sollen diese in neuen Spalten zum ersten Treffer kopiert und anschließend die Duplikatzeilen gelöscht werden.

Ergebnis-Beispiel:

Kundennummer | Geburtsdatum | Bemerkung | Geburtsdatum #1 | Bemerkung #1 | Geburtsdatum #2 | Bemerkung #2 | Geburtsdatum #3 | Bemerkung #3 | Geburtsdatum #4 | Bemerkung #4
1234 | 10.08.1984 | Lorem ipsum | 23.07.1954 | dolor sit amet | 03.07.1982 | consetetur | 17.02.1985 | sadipscing | 28.08.2013 | elitr
5475 | 01.01.2011 | Lorem ipsum
63124 | 04.04.1964 | dolor sit amet | 05.09.2000 | consetetur
9999 | 06.05.2010 | sadipscing

Ergebnis.JPG


Ziel:
Es soll am Schluss eine Excel-Tabelle entstehen in der die Inhalte mehrerer Datensätze mit der gleichen Kundennummer zu einem Datensatz zusammengeführt sind.


Nachdem es eine Lösung für Excel-Dateien mit unterschiedlichstem Aufbau sein soll brauche ich ein Makro. Formeln helfen mir nicht weiter, da diese bei jeder neuen Excel-Datei mit hohem Aufwand eingebunden werden müssten.

Ich habe bereits im Netz gesucht und ähnliche Ansätze gefunden, die aber nicht ausreichend sind. Geringe VBS-Kentnisse besitze ich zwar, aber keinerlei VBA-Kentnisse, weshalb ich die gefundenen Script nicht angepasst bekomme.

Folgendes Makro gefällt mir vom Aufbau her sehr gut, erfüllt aber leider nicht meine Anforderungen:

Code: 
Option Explicit
Public Sub Aufraeumen()
  Dim lFirstColumn As Long
  Dim lLastColumn As Long
  Dim lFirstRow As Long
  Dim lLastRow As Long
  Dim lLastColumnNew As Long
  Dim iFactor As Integer
  Dim lTotalRow As Long
  Dim dBlockRow As Double
  Dim lCopyFirstColumn As Long
  Dim lCopyLastColumn As Long
  Dim lCopyFirstRow As Long
  Dim lCopyLastRow As Long
  Dim i As Integer
  Dim j As Integer
 
  ' Datenbereich abfragen
  lFirstRow = 1
  lFirstColumn = 1
  lLastRow = Sheets(ActiveSheet.Name).UsedRange.SpecialCells(xlCellTypeLastCell).Row
  lLastColumn = Sheets(ActiveSheet.Name).UsedRange.SpecialCells(xlCellTypeLastCell).Column
 
  ' Aufteilungsfaktor angeben
  On Error Resume Next
  iFactor = InputBox("Bitte geben Sie den 'Aufräumfaktor' (> 1) an:", "Aufräumfaktor", 0)
  On Error GoTo 0
 
  ' ab Faktor > 1 soll aufgeteilt werden
  If iFactor > 1 Then
  ' Anzahl Zeilenblock ausrechnen
  lTotalRow = lLastRow - 1
  dBlockRow = lTotalRow / iFactor
  dBlockRow = WorksheetFunction.RoundUp(dBlockRow, 0)
  lCopyFirstRow = lFirstRow + 1
  lCopyLastRow = dBlockRow + 1
  lTotalRow = lTotalRow - dBlockRow
   
  ' Wert der letzten Spalte einer neuen Variable zuweisen
  lLastColumnNew = lLastColumn
   
  For i = 2 To iFactor
  ' Überschrift
  For j = 1 To lLastColumn
  lLastColumnNew = lLastColumnNew + 1
  Cells(lFirstRow, lLastColumnNew).Value = Cells(lFirstRow, j).Value & "-" & i
  Next j
   
  ' neuen Block ausrechnen
  On Error Resume Next
  dBlockRow = lTotalRow / (iFactor - i + 1)
  dBlockRow = WorksheetFunction.RoundUp(dBlockRow, 0)
  lTotalRow = lTotalRow - dBlockRow
  On Error GoTo 0
   
  ' Verschiebeaktion einbauen
  lCopyFirstRow = lCopyLastRow + 1
  lCopyFirstColumn = lFirstColumn
  lCopyLastRow = lCopyLastRow + dBlockRow
  lCopyLastColumn = lLastColumn
   
  Range(Cells(lCopyFirstRow, lCopyFirstColumn), Cells(lCopyLastRow, lCopyLastColumn)).Cut
  Cells(lFirstRow + 1, lLastColumnNew - lLastColumn + 1).Insert
  Next i
   
  Cells(1, 1).Select
  End If
End Sub

Das Makro splittet anhand des eingegebenen Werts die Zeilen in neue Spalten auf.

Beispiel:
Name | Vorname
Müller | Martin
Weber | Christian
Huber | Michael
Maier | Andrea
Walter | Christine
Kraus | Michaela

Eingabewert: 2

Die Anzahl der Zeilen wird durch 2 geteilt, Ergebnis ist dann 3. Die Zeilen werden nun auf 3 Bereiche aufgeteilt.

Ergebnis:
Name | Vorname | Name-1 | Vorname-1 | Name-2 | Vorname-2
Müller | Martin | Weber | Christian | Walter | Christine
Huber | Michael Maier | Andrea | Kraus | Michaela

Aus diesem Makro bräuchte ich:
- Inputbox
- Neue Spalten erzeugen und benennen
- Kopieren der erforderlichen Daten in die neuen Spalten

Das Makro müsste ich ergänzen um:
- Duplikate finden
- Duplikatzeilen in die neuen Spalten kopieren
- Kopierte Duplikatzeilen löschen

Ich hoffe unter euch schlauen Köpfen kann mir jemand helfen. Gerne auch mit einem anderen Makro-Ansatz der mein Ziel erfüllt.

Vielen Dank bereits vorab für alle die sich die Zeit nehmen meinen Beitrag zu lesen, sich Gedanken machen und mir Ansätze oder sogar eine Lösung geben! :)

LG
rince
 
Eine sehr spezielle Datenansicht, die du dir da erstellst.

Bis ich dir erklärt habe, wie ich das angehen würde, ist es einfacher eine fertige Lösung zu presentieren.
Ich arbeite darin mit Scripting.Dictionary (http://www.snb-vba.eu/VBA_Dictionary_en.html). Das musst du nicht installieren, das hast du bereits. Damit lassen sich Daten relativ elegant zusammensetzen.

Visual Basic: 
Public Sub test()
    Dim pk As Variant
    Dim maxCount As Long
    Dim colNr As Long
    Dim idx As Long
    Dim rowNrSrc            As Variant:
    'Variablen mit Initialwerten
    Dim rowNrTrg            As Long:        rowNrTrg = 1
    Dim uniqueColumnLetter  As String:      uniqueColumnLetter = InputBox("Unique Spalte Wählen")
    Dim wsSource            As Worksheet:   Set wsSource = ActiveWorkbook.Sheets("Sheet1")
    Dim wsTarget            As Worksheet:   Set wsTarget = ActiveWorkbook.Sheets.Add(, wsSource)
    Dim colCount            As Long:        colCount = xlsGetLastColumn(wsSource)
    Dim index               As Object:      Set index = CreateObject("scripting.Dictionary")
    Dim address             As String
   
    'Zusammenpassende Daten suchen
    'index = Dictionary(PrimaryKey => Dictionary(counter => RowNumber))
    For rowNrSrc = 2 To xlsGetLastRow(wsSource)
        address = uniqueColumnLetter & rowNrSrc
        pk = wsSource.Range(address).value
        'Falls der pk noch nicht vorhanden ist, neu anlegen
        If Not index.Exists(pk) Then index.Add pk, CreateObject("scripting.Dictionary")
        'Zeilennummer under dem PK speichern
        index(pk).Add index(pk).count, rowNrSrc
        'pk mit den meisten Zeilen bestimmen
        If maxCount < index(pk).count Then maxCount = index(pk).count
    Next rowNrSrc
   
    'Titelzeile schreiben
    For idx = 0 To maxCount - 1
        address = "A1:" & xlsColLetter(colCount) & "1"
        wsSource.Range(address).Copy wsTarget.Cells(rowNrTrg, (idx * colCount) + 1)
    Next idx
   
    'Zeilen Generieren. Für jeden pk eine Zeile
    For Each pk In index.keys
        'Zielzeilennumer eins hochzählen
        rowNrTrg = rowNrTrg + 1
        'Jede Quellzeile des pk kopieren
        For idx = 0 To index(pk).count - 1
            rowNrSrc = index(pk)(idx)
            address = "A" & rowNrSrc & ":" & xlsColLetter(colCount) & rowNrSrc
            wsSource.Range(address).Copy wsTarget.Cells(rowNrTrg, (idx * colCount) + 1)
        Next idx
    Next pk
   
    'überflüssige Key-SPalten entfernen
    For idx = maxCount To 1 Step -1
        wsTarget.Columns(idx * colCount + xlsColNumber(uniqueColumnLetter)).Delete
    Next idx
   
End Sub

Ich verwende darin 4 selbst geschriebene Funktionen, die so in Excel einfach fehlen...
xlsColLetter() Gibt den Buchstaben-Key für eine ExcelSpalte anhand einer Spaltennummer aus (Beginnend mit 1)
xlsColNumber() Umkehrfunction zu xlsColLetter: Berchent aus einem String-Colmnidex die Position
xlsGetLastRow() Ermittelt die letzte gefüllte Zeile eines Worksheets
xlsGetLastColumn() Ermittelt die letzte gefüllte Dpalte eines Worksheets

Visual Basic: 
'/**
' * Umkehrfunction zu xlsColLetter: Berchent aus einem String-Colmnidex die Position
' *
' * spaltennummer = xlsColNumber(spaltencode)
' *
' * @param  String
' * @retrun Long
'*/
Private Function xlsColNumber(ByVal iColumnLetter As String) As Long
    Const C_ASCII_DELTA = 64
    Dim str As String: str = StrReverse(UCase(iColumnLetter))
    Dim idx As Integer: For idx = 0 To Len(iColumnLetter) - 1
        xlsColNumber = xlsColNumber + 26 ^ idx * (Asc(Mid(str, idx + 1, 1)) - C_ASCII_DELTA)
    Next idx
End Function

'/**
' * Gibt den Buchstaben-Key für eine ExcelSpalte anhand einer Spaltennummer aus (Beginnend mit 1)
' *
' * spaltencode = clsColLetter(spaltennummer)
' *
' * @param  Long    Index der Spalte
' * @return String  Spaltenkey
' */
Public Function xlsColLetter(ByVal iColumnNumber As Long) As String
    Const C_ASCII_DELTA = 64
    Dim nr As Long: nr = iColumnNumber
    Do
        Dim rest As Integer: rest = nr Mod 26
        If rest = 0 Then rest = 26
        xlsColLetter = Chr(rest + C_ASCII_DELTA) & xlsColLetter
        nr = Fix((nr - 1) / 26)
    Loop While nr > 0
End Function

'/**
' * Ermittelt die letzte gefüllte Zeile eines Worksheets
' * @param  Worksheet   Das Worksheetobjekt, das durchsucht werden soll
' * @return Long        Die Zeilennummer. Wenn das ganze Sheet leer ist, ist der Rückgabewert 0
' */
Private Function xlsGetLastRow(ByRef sheet As Object) As Long
    Const xlCellTypeLastCell = 11

    'Zur letzten initialisierten Zeile gehen
    xlsGetLastRow = sheet.Cells.SpecialCells(xlCellTypeLastCell).Row
   
    'Von dort zurücksuchen bis zur Letzten zeile mit Inhalt
    Do While sheet.Application.WorksheetFunction.CountA(sheet.rows(xlsGetLastRow)) = 0 And xlsGetLastRow > 1
        xlsGetLastRow = xlsGetLastRow - 1
    Loop
End Function

'/**
' * Ermittelt die letzte gefüllte Dpalte eines Worksheets
' * @param  Worksheet   Das Worksheetobjekt, das durchsucht werden soll
' * @return Long        Die Zeilennummer. Wenn das ganze Sheet leer ist, ist der Rückgabewert 0
' */
Private Function xlsGetLastColumn(ByRef sheet As Object) As Long
    Const xlCellTypeLastCell = 11

    'Zur letzten initialisierten Zeile gehen
    xlsGetLastColumn = sheet.Cells.SpecialCells(xlCellTypeLastCell).Column
   
    'Von dort zurücksuchen bis zur Letzten zeile mit Inhalt
    Do While sheet.Application.WorksheetFunction.CountA(sheet.Columns(xlsGetLastColumn)) = 0 And xlsGetLastColumn > 1
        xlsGetLastColumn = xlsGetLastColumn - 1
    Loop
End Function
 
Hi Yaslaw,

vielen Dank für die schnelle und vor allem tolle Lösung! :)

Ich habe alle Funktionen in ein Modul eingebaut und getestet. Bei meinem ersten Versuch brachte der Excel Debugger einen Fehler in Zeile 10, weil ich ein deutsches Excel im Einsatz habe und es dort nicht "Sheet1" sondern "Tabelle1" heisst. Das konnte ich aber sofort lösen und anschließend hat es genau so funktioniert wie ich es mir vorgestellt habe.

Deinen Code kann ich größtenteils (vor allem wegen deiner Kommentierung) gut nachvollziehen und werde das in den kommenden Tagen intensiver studieren, damit ich etwas dazu lerne. Durch deine saubere Code Strukturierung sollte es mir auch gelingen.

Einzige Anpassung meinerseits:

Ich habe der Einfachheit halber die Zeile 10 umgeschrieben von...
Code: 
Dim wsSource            As Worksheet:   Set wsSource = ActiveWorkbook.Sheets("Sheet1")
bzw.
Code: 
Dim wsSource            As Worksheet:  Set wsSource = ActiveWorkbook.Sheets("Tabelle1")

...zu...
Code: 
Dim wsSource            As Worksheet:   Set wsSource = ActiveWorkbook.Activesheet

...damit immer das aktuell ausgewählte/aktive Tabellenblatt angesprochen wird.

LG rince
 
Um antworten zu können musst du eingeloggt sein.

Neue Beiträge

Zurück