VBA 对于重复行

Question

我有 sheet 列。我想比较多列中的数据，并在另一列中 return 一个标志来指示重复的行。我在网上找到了一些用于检查一列数据的代码，但到目前为止未能成功地对多列数据进行调整。最终代码将需要查看我将在稍后定义的特定列，但目前说 sheet 如下： StaffNumber 呼叫类型
1个
2乙
1个
4 D
5 乙
6女
7克
8小时
1个
2 C
1 Z
6P

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

我的代码如下：

子重复问题()

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

结束子

我的问题是，只有当 Col 1 重复时，宏才会将 "Duplicate" 输入到 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

.

结果：

VBA 对于重复行

VBA for duplicate rows

excel

vba

duplicates