Duplikate entfernen

Hallo an euch alle,
ich hoffe ihr habt eine möglichst einfache (zeitsparende) Lösung für das was ich vorhabe.
Habe eine Tabelle namens NV, 3 Spalten (A:C), 1805 Zeilen.
Ich würde gerne Duplikate in den Spalten A und B entfernen, jedoch die Inhalte der Spalte C nicht verlieren.
So stelle ich mir das vor:
https://www.herber.de/bbs/user/119277.xlsx
Zeilen 4 und 7 verschwinden, weil sie bezogen auf Spalte A und B Duplikate zu Zeile 2 sind, jedoch damit die Texte 7 und 12 nicht verloren gehen, sollen sie dann in zukünftig in den Spalten D ff. stehen.
Mir ist bewusst dass das ganze lösbar ist, indem ich die Tabelle nach Spalte A und B sortiere, die Texte aus Spalte C verkette und dann wieder "Text in Spalten" mache.
Jedoch befürchte ich dass die Texte dafür zu lang sind und zumindest in Einzelfällen die maximal mögliche Anzahl der Zeichen pro Zelle überschritten wird. Daher bitte ich um eine andere Lösung.
Gruß
Christian

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

' ********************************************************************** ' Modul: Modul1 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub removeD() Dim lngLast As Long Dim lngLastCol As Long On Error GoTo ErrorHandler Application.ScreenUpdating = False With Sheets("Tabelle1") 'Tabellenname - Anpassen! lngLast = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row) .Cells(2, 4).Formula = "=SUMPRODUCT((A2:A" & lngLast & "&B2:B" & lngLast & "=A2&B2)*1)" lngLastCol = 2 + .Cells(2, 4) With .Range(.Cells(2, 4), .Cells(lngLast, lngLastCol)) .Formula = "=IFERROR(INDEX($C$2:$C$" & lngLast & ",AGGREGATE(15,6,ROW($A$1:$A$" & lngLast - 1 & _ ")/($A$2:$A$" & lngLast & "&$B$2:$B$" & lngLast & "=$A2&$B2),COLUMN(B$1))),"""")" .Value = .Value End With With .Range(.Cells(2, lngLastCol + 1), .Cells(lngLast, lngLastCol + 1)) .Cells(1, 1).FormulaArray = "=IF(MATCH(A2&B2,$A$2:$A$" & lngLast & "&$B$2:$B$" & _ lngLast & ",0)=ROW(A1),ROW(),0)" .Columns(1).FillDown .Value = .Value End With .Cells(1, lngLastCol + 1) = 0 .Range(.Cells(1, 1), .Cells(1, lngLastCol)).SpecialCells(xlCellTypeBlanks).Value = "X" .Range(.Cells(1, 1), .Cells(lngLast, lngLastCol + 1)).RemoveDuplicates _ Columns:=lngLastCol + 1, Header:=xlNo .Columns(lngLastCol + 1).Delete End With ErrorHandler: Application.ScreenUpdating = True End Sub

Hallo Christian,
hier ein entsprechendes Makro.
Alternativ könnte man auch die Inhalte der Duplikate in Spalte C in Spalte C der 1. Zeile inkl. Zeilenschaltung hinzufügen.
Gruß
Franz

Sub Daten_umgruppieren()
Dim wksQ As Worksheet
Dim Zeile As Long, Zeile_L As Long, Zeile_1 As Long, Zeile_2 As Long
Dim arrData
Dim varA, varB, Spalte As Long
Dim arrDone() As Boolean
Set wksQ = ActiveSheet
'Kopie vom Originalblatt erstellen
wksQ.Copy after:=wksQ 'Diese Zeile weglassen, wenn im gleichen Blatt umgruppiert werden soll
Set wksQ = ActiveSheet
With wksQ
Zeile_L = .Cells(.Rows.Count, 1).End(xlUp).Row
arrData = .Range(.Cells(1, 1), .Cells(Zeile_L, 2))
ReDim arrDone(LBound(arrData) To UBound(arrData))
Application.ScreenUpdating = False
For Zeile = 1 To Zeile_L
Zeile_1 = Zeile 'Zeile merken, in die Werte von Duplikaten kopiert werden sollen
If arrDone(Zeile) = False Then
'Vergleichswerte merken
varA = arrData(Zeile, 1)
varB = arrData(Zeile, 2)
'Spaltenzähler zurücksetzen
Spalte = 3
arrDone(Zeile) = True 'Zeile als erledigt markieren
For Zeile_2 = Zeile_1 + 1 To Zeile_L
'prüfen ob Zeile schon erledigt
If arrDone(Zeile_2) = False Then
'Werte in Zeile mit gemerkten Werten vergleichen
If arrData(Zeile_2, 1) = varA And arrData(Zeile_2, 2) = varB Then
Spalte = Spalte + 1
'Zelle in Spalte 3 in gemerkte 1. Zeile kopieren
.Cells(Zeile_2, 3).Copy .Cells(Zeile_1, Spalte)
.Rows(Zeile_2).ClearContents 'Inhalte in Duplikat-Zeile löschen
arrDone(Zeile_2) = True 'Zeile als erledigt markieren
End If
End If
Next
End If
Next
'entstandene Leerzeilen löschen
With .Range(.Cells(1, 1), .Cells(Zeile_L, 1))
If Application.WorksheetFunction.CountBlank(.Cells) > 0 Then
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
End With
Application.ScreenUpdating = True
Erase arrData, arrDone
End With
End Sub

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread