Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1604to1608
1604to1608
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Duplikate entfernen

Forumthread: Duplikate entfernen

Duplikate entfernen
26.01.2018 09:02:04
Christian
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
Anzeige

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

Betreff
Datum
Anwender
Anzeige
AW: Duplikate entfernen
26.01.2018 09:57:35
Sepp
Hallo Christian,
teste mal.
In ein allgemeines Modul.
' **********************************************************************
' 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

Gruß Sepp

Anzeige
AW: Duplikate entfernen
26.01.2018 10:00:17
fcs
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

Anzeige
AW: Duplikate entfernen
26.01.2018 11:37:57
Christian
Hallo Sepp,
hallo Franz,
vielen Dank für eure Mühe.
habe beide Makros getestet.
Zu dir, Franz, jetzt hat die Tabelle nur noch 1275 Zeilen und insgesamt 1805 Einträge in den Spalten C bis AK.
Hab jetzt noch keine intensiven Vergleiche gemacht, aber es sieht so aus als hätte es funktioniert.
Zu dir Sepp,
nachdem ich dein Makro ausgeführt hatte, hatte ich nur noch einen einzigen Text in der Tabelle, in C1. Dafür eine Unmenge an Zahlen im Rest von den Spalten C und D.
Die Zeilenanzahl ist auch bei 1805 geblieben.
Viele Grüße
Christian
Anzeige
AW: Duplikate entfernen
26.01.2018 12:02:09
Sepp
Hallo Christian,
dann hat dein Beispiel nichts mit deiner Originaltabelle zu tun, in deiner Beispieltabelle klappt es 100%ig.
Gruß Sepp

AW: Duplikate entfernen
26.01.2018 12:11:02
Christian
Hallo Sepp,
die einzigen Unterschiede die mir spontan einfallen ist das ein kleiner Teil ganz am Ende der Texte im Original aus mehreren nicht nur einem Wort bestehen und dass dieselben Texte im Originaleinen Hyperlink zu einer Internetseite haben (der aber sowieso nicht gebraucht wird, daher war es mir egal ob er durch diese Aktion hier gelöscht wird oder erhalten bleibt).
Gruß
Christian
Anzeige
ein Unterschied fällt mir doch noch ein
26.01.2018 12:15:33
Christian
Die Beispieldatei hatte eine Überschrift in Zeile 1, das Original nicht, sorry da hätte ich dran denken müssen
;

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige