VBA - Löschen doppelter Zeilen und Zusammenführen von Zellen mit eindeutigen Daten

Question

Ich möchte einige Hilfe in Bezug auf das folgende Problem haben. Jedes Quartal haben wir Excel-Sheets an uns geschickt mit Client-Informationen mit Zeilen oft mehr als eine 1000. Ich habe es geschafft, einen Code zu schreiben, der doppelte Zeilen löscht, die eine 100% Übereinstimmung sind, jedoch bleibt ein beträchtlicher Teil aufgrund der folgende:

Ein neuer Code, den ich irgendwie funktioniert gefunden haben, aber ich würde etwas Hilfe brauchen sie zwicken, wie es das folgende tut:

es das Duplikat löscht und führt die Zellen, Wenn jedoch ein Zellenwert (in diesem Fall Marketing) beide Male angezeigt wird, wird er zweimal gespeichert. Auch ist es nicht behalten andere Informationen wie E-Mail/Name/Telefon usw.

Hier ist der Code selbst:

Sub Main() 
Dim Source As Worksheet: Set Source = ThisWorkbook.Worksheets("Sheet1") 
Dim Destination As Worksheet: Set Destination = ThisWorkbook.Worksheets("Sheet2") 

Dim Records As Object: Set Records = CreateObject("Scripting.Dictionary") 

Dim Data As Variant 
Dim Index As Long 
Dim Row As Integer: Row = 1 

Data = Source.Range("A1", "E" & Source.Rows(Source.UsedRange.Rows.Count).Row).Value2 

For Index = LBound(Data, 1) To UBound(Data, 1) 
If Records.Exists(Data(Index, 1)) Then 
    Destination.Cells(Records(Data(Index, 1)), 5).Value2 = Destination.Cells(Records(Data(Index, 1)), 5).Value2 & ", " & Data(Index, 5) 
Else 
    Records.Add Data(Index, 1), Row 
    Destination.Cells(Row, 1).Value2 = Data(Index, 1) 
    Destination.Cells(Row, 5).Value2 = Data(Index, 5) 
    Row = Row + 1 
End If 
Next Index 

Set Records = Nothing 

End Sub 

Ich habe mich gefragt, ob es einen Weg gibt, dieses Problem zu lösen, oder ist es zu kompliziert ? Wenn Letzteres, keine Probleme, nur das Löschen der Duplikate funktioniert gut und reduziert die Arbeitszeit sehr.

Vielen Dank für Ihre Eingabe und Kommentar!

Answer 1

ich ein Wörterbuch verwenden Duplikate in einem Komma abgrenzen Zeichenfolge zu entfernen. E-Mail, Code und Land werden ebenfalls in das Zielarbeitsblatt kopiert.

Sub Main() 
    Dim Source As Worksheet: Set Source = ThisWorkbook.Worksheets("Sheet1") 
    Dim Destination As Worksheet: Set Destination = ThisWorkbook.Worksheets("Sheet2") 
    Dim Records As Object: Set Records = CreateObject("Scripting.Dictionary") 

    Dim Data As Variant 
    Dim Index As Long 
    Dim Row As Integer: Row = 1 

    Data = Source.Range("A1", "E" & Source.Rows(Source.UsedRange.Rows.Count).Row).Value2 
    With Destination 

     For Index = LBound(Data, 1) To UBound(Data, 1) 
      If Records.Exists(Data(Index, 1)) Then 
       Destination.Cells(Records(Data(Index, 1)), 5).Value2 = removeDuplicates(Destination.Cells(Records(Data(Index, 1)), 5).Value2 & ", " & Data(Index, 5)) 
      Else 
       Records.Add Data(Index, 1), Row 
       Destination.Cells(Row, 1).Value2 = Data(Index, 1) 
       Destination.Cells(Row, 2).Value2 = Data(Index, 2) 
       Destination.Cells(Row, 3).Value2 = Data(Index, 3) 
       Destination.Cells(Row, 4).Value2 = Data(Index, 4) 
       Destination.Cells(Row, 5).Value2 = Data(Index, 5) 
       Row = Row + 1 
      End If 
     Next Index 

    End With 
    Set Records = Nothing 

End Sub 

Function removeDuplicates(values As String) 
    Dim v As Variant 
    Dim d As Object 
    Set d = CreateObject("Scripting.Dictionary") 

    For Each v In Split(values, ",") 
     If v <> "" Then d(v) = 1 
    Next 

    removeDuplicates = Join(d.Keys, ", ") 

    Set d = Nothing 
End Function 

Answer 2

Probieren Sie die folgenden

If Records.Exists(Data(Index, 1)) Then 
    If InStr(Destination.Cells(Records(Data(Index, 1)), 5).Value2, Data(Index, 5)) = 0 Then 
     Destination.Cells(Records(Data(Index, 1)), 5).Value2 = Destination.Cells(Records(Data(Index, 1)), 5).Value2 & ", " & Data(Index, 5) 
    End if 
... 

InStr sucht nach einem bestimmten String in einem anderen, und gibt die Position, an der die Zeichenfolge gefunden wird. Wenn also Marketing nicht gefunden wird, gibt Instr 0 zurück und es wird zur Zelle hinzugefügt. Wenn es bereits vorhanden ist, gibt Instr etwas größer als 0 zurück und es wird nicht erneut hinzugefügt.

aktualisieren Wenn Sie mehrere Datensätze mit mehr als einem Gerät haben, versuchen Sie diese

UnitFull = Data(Index, 5) 

Do Until Len(UnitFull) = 0 
    If InStr(UnitFull, ",") > 0 Then 
     Unit = Left(UnitFull, Instr(UnitFull, ",") - 1) 
     UnitFull = Trim(Right(UnitFull, Len(UnitFull) - InStr(UnitFull, ","))) 

    Else 

     Unit = UnitFull 
     UnitFull = "" 

    End If 

    Destination.Cells(Records(Data(Index, 1)), 5).Value2 = Destination.Cells(Records(Data(Index, 1)), 5).Value2 & ", " & Unit 

    Unit = "" 

Loop