VBA for duplicate rows

Question

I have a sheet of columns. I want to compare data in multiple columns, and return a flag in another column to indicate rows that are duplicates. I found a little code online which was meant for checking one column of data, and have so far been unsuccessful in being able to tweek it for multiple columns. The final code will need to look at specific columns which I will define later however for the moment say the sheet is as follows: 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

The Col A is labelled Staff Number. Col B is labelled CallType. In Col C I want the flag to be entered against the row.

My Code is as follows:

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

My problem is that only when Col 1 is a duplicate will the macro enter "Duplicate" into Col C, and it is not checking if the value of Col B is also the same. Any Help would be much appreciated.

Answer 1

Try this code:

.

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

.

Result: