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