How to delete duplicate values and original values across multiple sheets in excel

Remove Duplicates and Originals in Multiple Worksheets

Option Explicit

Sub RemoveDupes()

    Const wsNamesList As String = "Sheet1,Sheet2,Sheet3"
    Const HeaderTitle As String = "Class"
    Const HeaderRow As Long = 1
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim wsNames() As String: wsNames = Split(wsNamesList, ",")
    Dim nUpper As Long: nUpper = UBound(wsNames)
    
    Dim cRanges() As Range: ReDim cRanges(0 To nUpper)
    Dim cData() As Variant: ReDim cData(0 To nUpper)
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' A = a
    
    Dim ws As Worksheet
    Dim crg As Range
    Dim hCell As Range
    Dim n As Long
    
    For n = 0 To nUpper
        ' Attempt to create a reference to the worksheet ('ws').
        Set ws = RefWorksheet(wb, wsNames(n))
        If Not ws Is Nothing Then
            ' Attempt to create a reference to the header cell ('hCell').
            Set hCell = RefHeader(ws, HeaderTitle, HeaderRow)
            If Not hCell Is Nothing Then
                ' Attempt to create a reference to the range ('crg').
                Set crg = RefColumnRange(hCell.Offset(1))
                If Not crg Is Nothing Then
                    ' Store the range in an array ('cRanges').
                    Set cRanges(n) = crg
                    ' Write the values from the ranges to an array ('cData').
                    cData(n) = GetColumnRange(crg)
                    ' Write and count the unqiue values from the array
                    ' to a dictionary ('dict').
                    FirstColumnToDictionaryWithCount dict, cData(n)
                End If
            End If
        End If
    Next n
                    
    Dim drg() As Range: ReDim drg(0 To nUpper)
    Dim r As Long
    
    ' Combine all cells containing duplicates (and the originals)
    ' into one range ('drg()') per worksheet.
    For n = 0 To nUpper
        If Not cRanges(n) Is Nothing Then
            For r = 1 To UBound(cData(n), 1)
                If dict(cData(n)(r, 1)) > 1 Then
                    Set drg(n) = GetCombinedRange(drg(n), cRanges(n).Cells(r))
                End If
            Next r
        End If
    Next n
        
    Application.ScreenUpdating = True
    
    ' Delete the entire rows of the ranges in one go per worksheet.
    For n = 0 To nUpper
        If Not drg(n) Is Nothing Then
            drg(n).EntireRow.Delete
        End If
    Next n
                    
    Application.ScreenUpdating = False
    
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      In a workbook ('wb'), creates a reference to the worksheet
'               named after a value ('WorksheetName').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefWorksheet( _
    ByVal wb As Workbook, _
    ByVal WorksheetName As String) _
As Worksheet
    If wb Is Nothing Then Exit Function
    
    On Error Resume Next
    Set RefWorksheet = wb.Worksheets(WorksheetName)
    On Error GoTo 0
    
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      In a worksheet's ('ws') row ('HeaderRow'), creates a reference
'               to the cell containing a value ('Title').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefHeader( _
    ByVal ws As Worksheet, _
    ByVal Title As String, _
    Optional ByVal HeaderRow As Long = 1) _
As Range
    If ws Is Nothing Then Exit Function
    If HeaderRow < 1 Then Exit Function
    If HeaderRow > ws.Rows.Count Then Exit Function
    
    Dim hCell As Range
    With ws.Rows(HeaderRow)
        Set hCell = .Find(Title, .Cells(.Cells.Count), xlFormulas, xlWhole)
    End With
    If hCell Is Nothing Then Exit Function
    
    Set RefHeader = hCell
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to a one-column range from a cell
'               ('FirstCellRange') to the bottom-most non-empty cell.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumnRange( _
    ByVal FirstCellRange As Range) _
As Range
    If FirstCellRange Is Nothing Then Exit Function
    
    Dim lCell As Range
    With FirstCellRange.Cells(1)
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function
        Set RefColumnRange = .Resize(lCell.Row - .Row + 1)
    End With

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of a one-column range ('ColumnRange')
'               in a 2D one-based one-column array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetColumnRange( _
    ByVal ColumnRange As Range) _
As Variant
    If ColumnRange Is Nothing Then Exit Function
    
    Dim rCount As Long: rCount = ColumnRange.Rows.Count
    
    Dim cData As Variant
    
    With ColumnRange.Columns(1)
        If rCount = 1 Then
            ReDim cData(1 To 1, 1 To 1): cData(1, 1) = .Value
        Else
            cData = .Value
        End If
    End With
    
    GetColumnRange = cData
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Appends the unique values and their count of the first column
'               of a 2D one-based array ('cData') to a dictionary ('dict').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub FirstColumnToDictionaryWithCount( _
        ByRef dict As Object, _
        ByVal cData As Variant)
    If dict Is Nothing Then Exit Sub
    If IsEmpty(cData) Then Exit Sub
    
    Dim cValue As Variant
    Dim r As Long
    
    For r = 1 To UBound(cData, 1)
        cValue = cData(r, 1)
        If Not IsError(cValue) Then
            If Len(cValue) > 0 Then
                dict(cValue) = dict(cValue) + 1
            End If
        End If
    Next r

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Combines two ranges into one range.
'               Note that the ranges have to be located in the same worksheet.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetCombinedRange( _
    ByVal BuiltRange As Range, _
    ByVal AddRange As Range) _
As Range
    
    If BuiltRange Is Nothing Then
        Set GetCombinedRange = AddRange
    Else
        Set GetCombinedRange = Union(BuiltRange, AddRange)
    End If

End Function

Option Explicit

Sub DeleteDuplRows()
'https://stackoverflow.com/questions/68342367/ _
    how-to-delete-duplicate-values-and-original-values-across-multiple-sheets-in-exc

Dim wb As Workbook, wShs As Object
Dim i As Long, Col As Range, ColRange() As Range, ColRangeStr As String
Dim ColRangeStrArr() As String, str As Variant, Cl As Range, ShtDelRange As Range
Dim ClassNames As Object
Set ClassNames = CreateObject("Scripting.Dictionary")
Dim DuplClassNames As Object
Set DuplClassNames = CreateObject("Scripting.Dictionary")

Set wb = ThisWorkbook
Set wShs = wb.Worksheets
ReDim ColRange(1 To wShs.Count)

'Make ColRange array of ranges for "Class" column from each sheet
For i = 1 To wShs.Count
    Set Col = wShs(i).Rows(1).Find("Class")
    If Not Col Is Nothing Then
        Set ColRange(i) = wShs(i).Range(wShs(i).Cells(2, Col.Column), _
                wShs(i).Cells(wShs(i).UsedRange.Rows.Count, Col.Column))
    End If
Next i

'Make ColRangeStr string of values of cells from each range element of the above ColRange array,
ColRangeStr = ""
For i = LBound(ColRange) To UBound(ColRange)
    ColRangeStr = ColRangeStr & "," & Join(Application.Transpose(Application.Index( _
        ColRange(i), 0, 1)), ",")
Next i
ColRangeStr = Right(ColRangeStr, Len(ColRangeStr) - 1)

'Split the ColRangeStr string into ColRangeStrArr array
ColRangeStrArr = Split(ColRangeStr, ",")

'Make DuplClassNames dictionary of duplicate values from the above ColRangeStrArr array
With ClassNames
.CompareMode = TextCompare
For Each str In ColRangeStrArr
If Not Len(str) = 0 Then
    If Not .Exists(str) Then
        .Add str, Nothing
        Else
        If Not DuplClassNames.Exists(str) Then DuplClassNames.Add str, Nothing
    End If
End If
Next str
End With

'Make ShtDelRange union of DUPLICATE cells from "class" column of each sheet if the cell value _
    exists in DuplClassNames dictionary.
For i = LBound(ColRange) To UBound(ColRange)
    Set ShtDelRange = Nothing
    For Each Cl In ColRange(i)
        If DuplClassNames.Exists(Cl.Value) Then
            If ShtDelRange Is Nothing Then
                Set ShtDelRange = Cl
                Else
                Set ShtDelRange = Union(ShtDelRange, Cl)
            End If
        End If
    Next Cl
'Delete entire rows of the Sheets(i) if the cells are in ShtDelRange
If Not ShtDelRange Is Nothing Then ShtDelRange.EntireRow.Delete
Next i

End Sub