Excel - Markieren und Entfernen doppelter Spaltenwerte in der Zeile

Question

Ich arbeite an einem großen Dokument mit mehreren hundert Datenspalten. Viele dieser Zeilen enthalten doppelte Werte, die ich entfernen muss.

Hier ist ein Beispielblatt:

Ich muss jede Zeile durchgehen können, die Duplikate in den Spalten B:E finden und alle Zellen bis auf eine löschen können. Die restlichen Zellen muss ich vorzugsweise nach links verschieben, um leere Zellen zu vermeiden. Ich müsste alle Zeilen und den Rest ihrer Daten intakt lassen.

Im obigen Beispiel würde das Ergebnis also folgendermaßen aussehen:

Ein paar Anmerkungen:

• Die betreffenden Zellen erscheinen alle am Ende jeder Zeile
• Begründung: Alle diese Werte wurden als Liste in einer einzelnen Spalte gespeichert und mithilfe von aufgeteilt Text to Columns. Ich muss das jetzt bereinigen und die Duplikate entfernen.
• Es gibt Tausende von Zeilen und einige Hundert zusätzliche Spalten, die Duplikate enthalten können.

Ist das möglich, sogar mit VBA? Alle Vorschläge sind sehr willkommen. Vielen Dank!

Answer 1

Hier sind die Ergebnisse des Geschwindigkeitstests für die geposteten Antworten (10.000 Zeilen und 1.000 Spalten):

VBA 1 - Time:  19.488 sec - RemoveRowDupes (this answer)

VBA 2 - Time: 109.434 sec - dostuff (after turning off ScreenUpdating)

Formula test: N/A (gave up after 5 minutes filling out 10Kx1K range with array, at 9%)

---

Option Explicit
Public Sub RemoveRowDupes()
    Dim ur As Range, cc As Long, r As Range, a As Variant
    Dim s As String, i As Long, l As Long, t As Long, tt As Double, tr As String
    tt = Timer
    Set ur = Sheet1.UsedRange
    cc = ur.Columns.Count - 1
    With ur.Offset(, 1).Resize(, cc)
        Application.ScreenUpdating = False
        For Each r In .Rows
            s = Join(Application.Transpose(Application.Transpose(r)), "|")
            a = Split(s, "|"):
            l = Len(s)
            For i = 0 To cc - 1
                If Len(a(i)) > 0 Then
                    s = Replace(s, a(i), "^^")
                    s = Replace(s, "^^", a(i), , 1)
                    s = Replace(s, "^^", vbNullString)
                    If l > Len(s) Then
                        a = Split(s, "|")
                        l = Len(s)
                    End If
                End If
            Next
            s = Replace(s, "||", "|")
            If Right(s, 1) = "|" Then s = Left(s, Len(s) - 1)
            t = Len(s) - Len(Replace(s, "|", ""))
            r.ClearContents:    r.Resize(, t + 1) = Split(s, "|")
        Next
        Application.ScreenUpdating = True
    End With
    tr = "Rows: " & Format(ur.Rows.Count,"#,###") & "; Cols: " & Format(cc,"#,###") & "; "
    Debug.Print tr & "Time: " & Format(Timer - tt, "0.000") & " sec - RemoveRowDupes()"
End Sub

---

Testdaten:

---

Ergebnis - RemoveRowDupes()

---

Ergebnis - dostuff()

---

Notiz:Diese Antwort kann (falls erforderlich) durch die Verwendung von Arrays anstelle der Interaktion mit dem Bereich verbessert werden

Answer 2

Wenn Sie VB zur Verarbeitung der Daten vor Ort verwenden möchten, können Sie Folgendes verwenden:

Sub dostuff()
Dim myarray As Variant
ReDim myarray(10000)

i = 0 'row iterator

Do While (Range("A1").Offset(i, 0).Value <> "")
 j = 0 'single item iterator
 k = 0 'column iterator
 m = 0 'stored array iterator
 m_max = 0 'number of unique values on the row

 'iterate single values
 Do While (Range("B1").Offset(i, j).Value <> "")
  temp = Range("B1").Offset(i, j).Value

  'compare to saved
  flag = 0
  m = 0
  Do While (m <= m_max)
   If temp = myarray(m) Then
     flag = 1
   End If
   m = m + 1
  Loop

  'add if unique
  If flag = 0 Then
   m_max = m_max + 1
   myarray(m_max) = temp
  End If

  j = j + 1
 Loop

 'clear existing
 Range("B1").Offset(i, 0).Select
 Range(Selection, Selection.End(xlToRight)).Clear

 'write saved
 m = 1
 Do While m <= m_max
  Range("B1").Offset(i, m - 1).Value = myarray(m)
  m = m + 1
 Loop

  i = i + 1
Loop
End Sub

Answer 3

Sie können dies mit einer Formel tun, aber die richtigen Werte befinden sich dann zumindest vorübergehend an einem anderen Ort. Um Ihre Daten am gleichen Ort zu behalten, können Sie die neuen Daten kopieren und mit „Inhalte einfügen“ > „Werte“ die alten Daten überschreiben.

Diese Matrixformel, die von rechts nach unten ab B7 ausgefüllt wird, ergibt die unten gezeigten Ergebnisse:

=IFERROR(INDEX($B1:$E1,,MATCH(0,COUNTIF($A7:A7,$B1:$E1),0)),"")

Beachten Sie, dass dies eine Array-Formel ist und mit eingegeben werden muss CTRLShiftEnter.

Ein Tutorial zur Funktionsweise dieser Formel finden Sie unterExceljet.