重复行

Question

我有一张专栏。 我想比较多列中的数据，并在另一列中返回一个标志，以指示重复的行。我在网上发现了一些用于检查一列数据的代码，到目前为止还没有成功地为多列调整它。最终的代码需要查看我将在稍后定义的特定列，但是暂时说明表如下： StaffNumber CallType
1 A
2 B
1 A
4 D
5 E
6 F
7 G
8 H
1 A
2 C
1 Z
6 P

Col A标有员工编号。 Col B标记为CallType。在Col C中，我希望在行中输入标志。

我的代码如下：

Sub DuplicateIssue（）

Dim last_StaffNumber As Long
Dim last_CallType As Long

Dim match_StaffNumber As Long
Dim match_CallType As Long

Dim StaffNumber As Long
Dim CallType As Long

last_StaffNumber = Range("A65000").End(xlUp).Row
last_CallType = Range("B65000").End(xlUp).Row

For StaffNumber = 1 To last_StaffNumber
For CallType = 1 To last_CallType

    'checking if the Staff Number cell is having any item, skipping if it is blank.
        If Cells(StaffNumber, 1) <> " " Then

        'getting match index number for the value of the cell
            match_StaffNumber = WorksheetFunction.Match(Cells(StaffNumber, 1), Range("A1:A" & last_StaffNumber), 0)

            If Cells(CallType, 2) <> " " Then

            match_CallType = WorksheetFunction.Match(Cells(CallType, 2), Range("B1:B" & last_CallType), 0)

                'if the match index is not equals to current row number, then it is a duplicate value
                If StaffNumber <> match_StaffNumber And CallType <> match_CallType Then
                    'Printing the label in the column C
                    Cells(StaffNumber, 3) = "Duplicate"
                End If
            End If
        End If
Next
Next

End Sub

我的问题是，只有当Col 1重复时，宏才会输入＆＃34; Duplicate＆＃34;进入Col C，并没有检查Col B的值是否也相同。 非常感谢任何帮助。

Answer 1

试试这段代码：

Option Explicit

Public Sub showDuplicateRows()
    Const SHEET_NAME    As String = "Sheet1"
    Const LAST_COL      As Long = 3 ' <<<<<<<<<<<<<<<<<< Update last column
    Const FIRST_ROW     As Long = 2
    Const FIRST_COL     As Long = 1
    Const DUPE          As String = "Duplicate"
    Const CASE_SENSITIVE As Byte = 1                    'Matches UPPER & lower

    Dim includedColumns As Object
    Set includedColumns = CreateObject("Scripting.Dictionary")
    With includedColumns
        .Add 1, ""  ' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< col 1 as dupe criteria
        .Add 3, ""  ' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< col 3 as dupe criteria
    End With
    Dim searchRng       As Range
    Dim memArr          As Variant
    Dim i               As Long
    Dim j               As Long
    Dim unique          As String
    Dim totalRows       As Long
    Dim totalCols       As Long
    Dim totalURCols     As Long
    Dim valDict         As Object
    Set valDict = CreateObject("Scripting.Dictionary")

    If CASE_SENSITIVE = 1 Then
        valDict.CompareMode = vbBinaryCompare
    Else
        valDict.CompareMode = vbTextCompare
    End If
    With ThisWorkbook.Sheets(SHEET_NAME)
        totalRows = .UsedRange.Rows.Count               'get last used row on sheet
        totalURCols = .UsedRange.Columns.Count          'get last used col on sheet
        Set searchRng = .Range( _
                                .Cells(FIRST_ROW, FIRST_COL), _
                                .Cells(totalRows, LAST_COL) _
                                )
        If LAST_COL < totalURCols Then
                        .Range( _
                                .Cells(FIRST_ROW, LAST_COL + 1), _
                                .Cells(FIRST_ROW, totalURCols) _
                                ).EntireColumn.Delete   'delete any extra columns
        End If
    End With

    memArr = searchRng.Resize(totalRows, LAST_COL + 1)  'entire range with data to mem

    For i = 1 To totalRows                              'each row, without the header
        For j = 1 To LAST_COL                           'each col
            If includedColumns.exists(j) Then
                unique = unique & searchRng(i, j)       'concatenate values on same row
            End If
        Next
        If valDict.exists(unique) Then                  'check if entire row exists
            memArr(i, LAST_COL + 1) = DUPE              'if it does, flag it in last col
        Else
            valDict.Add Key:=unique, Item:=i            'else add it to the dictionary
        End If
        unique = vbNullString
    Next
    searchRng.Resize(totalRows, LAST_COL + 1) = memArr  'entire memory back to the sheet
End Sub

结果：