excel - 如何识别具有不同值的一个值的重复项

Question

我想编写一个宏来识别 excel 中具有不同值的一个值的重复。

如果您看到下图，则有 2 个集群具有不同的州和城市，以黄色突出显示。我希望这些簇 # 应该出现在 A 列的 Sheet2 中。

标签： excelvba

Answer 1

你可以试试：

Option Explicit

Sub test()

    Dim i As Long, y As Long, w As Long, LastRow As Long, LastRow2 As Long
    Dim Cluster1 As String, Cluster2 As String, FullDesc1 As String, FullDesc2 As String
    Dim rng As Range
    Dim Diff As Boolean

    'Change sheet name if needed
    With ThisWorkbook.Worksheets("Sheet1")

        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        Set rng = .Range("A2:A" & LastRow)

        For i = LastRow To 2 Step -1

            If .Range("A" & i).Value <> "" Then

                Cluster1 = .Range("A" & i).Value

                If WorksheetFunction.CountIf(rng, Cluster1) > 1 Then

                    FullDesc1 = Cluster1 & "_" & .Range("B" & i).Value & "_" & .Range("C" & i).Value

                    Diff = False

                    For y = LastRow To 2 Step -1

                        If y < i Then

                            Cluster2 = .Range("A" & y).Value
                            FullDesc2 = Cluster2 & "_" & .Range("B" & y).Value & "_" & .Range("C" & y).Value

                            If (Cluster1 = Cluster2) And (FullDesc1 <> FullDesc2) Then
                                Diff = True
                                Exit For
                            Else
                                Diff = False
                            End If

                        End If

                    Next y

                     If Diff = True Then

                        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

                        For w = LastRow To 2 Step -1

                            If .Range("A" & w).Value = Cluster1 Then

                                LastRow2 = ThisWorkbook.Worksheets("Sheet2").Cells(ThisWorkbook.Worksheets("Sheet2").Rows.Count, "A").End(xlUp).Row
                                .Range("A" & w & ":C" & w).Cut ThisWorkbook.Worksheets("Sheet2").Range("A" & LastRow2 + 1)
                                .Rows(w).EntireRow.Delete

                            End If

                        Next w

                    End If

                End If

            End If

        Next i

    End With

End Sub