VBA - 刪除重複的行和合並具有唯一數據的單元格

Question

我想對以下問題提供一些幫助。每個季度，我們都會向客戶發送包含行數超過1000的客戶信息的Excel表。我設法編寫了刪除100％匹配的重複行的代碼，但是，由於以下：

一個新的代碼，我發現還挺有效，但我需要一些幫助調整它，因爲它具有以下功能：

它刪除重複和合並單元格，然而，如果一個單元格值（在這種情況下是市場營銷）出現兩次，它將保留兩次。此外，不保留如郵件/姓名/電話等

這裏其他信息是代碼本身：

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 

我想知道如果有解決這個問題的方法，或者是太複雜？如果是後者，沒有問題，只有刪除重複的工作正常，並減少很多工作時間。

謝謝您的任何意見和建議！

Answer 1

我用字典來刪除逗號劃定字符串重複。電子郵件，代碼和國家也被複制到目標工作表。

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

嘗試使用以下

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函數搜索在另一特定字符串，並返回該串被發現的位置。因此，如果Marketing未找到，instr將返回0，並將其添加到單元格中。如果已經存在，Instr將返回大於0的值，並且不會再次添加。

更新如果您有更多的記錄與一個以上的單位，試試這個

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