VBA - 删除重复行并使用唯一数据合并单元格

Question

我想就以下问题提供一些帮助。每个季度我们都有一个excel表格发送给我们的客户信息包含通常超过1000的行。我设法编写一个代码删除100％匹配的重复行，但是，相当一部分仍然由于以下内容：

我发现一个新代码有点工作，但我需要一些帮助调整它，因为它执行以下操作：

删除副本并合并单元格，但是，如果一个单元格值（在本例中为Marketing）出现两次，则会保留两次。此外，它不会保留其他信息，如邮件/姓名/电话等。

以下是代码本身：

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

尝试以下

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

InStr在另一个中搜索某个String，并返回找到该字符串的位置。因此，如果未找到Marketing，instr将返回0并将其添加到单元格中。如果已经存在，Instr将返回大于0的内容，并且不会再次添加。

更新如果您有多个包含多个单元的记录，请尝试使用

BlueToothManager bm;  // --> sensor chip manager

// Configure BlueToothManager.
        bm= new BlueToothManager (this);


private void initBluetooth() {
        // Check if device supports Bluetooth Low Energy.
        if (!bm.hasBluetooth()) {
            //Toast.makeText(this, "Device does not have Bluetooth Low Energy", Toast.LENGTH_LONG).show();
            return;
        }

        // If Bluetooth is not enabled, let user enable it.
        if (!bm.isBluetoothEnabled()) {
            Intent enableBtIntent = new Intent(BluetoothAdapter.ACTION_REQUEST_ENABLE);
            startActivityForResult(enableBtIntent, Constant.REQUEST_ENABLE_BT);
        } else {
            Log.v(this.getClass(), "---> bluetooth already is enabled");
            startBMService();   // --> this function should be from your sensor chip api documents.
        }
    }

Answer 2

我使用Dictionary删除逗号分隔字符串中的重复项。电子邮件，代码和国家/地区也会复制到目标工作表。

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