Identify duplicate values with MsgBox-CodePudding

I have written VBA code to find the duplicate value and bulk upload the data to another sheet.

If any duplicate in A, B, C Columns I need a message box, and to cancel the bulk upload.

Example of my columns - marked in red are duplicate values:

Option Explicit
    
Private Sub CommandButton1_Click()
    Dim rng As Range
    Dim l As Long, r As Long, msg As String
    Dim lRow, lRow1 As Long
    
    Application.ScreenUpdating = False
    
    l = Range("A" & Rows.Count).End(xlUp).Row
    
    For r = 2 To l
        If Evaluate("COUNTIFS(A:A,A" & r & ",B:B,B" & r & ",C:C,C" & r & ")") > 1 Then msg = msg & vbCr & r
    Next
    MsgBox msg, vbInformation, "DUPLICATE ROWS"
        
    Exit Sub
    
    lRow = [Sheet2].Cells(Rows.Count, 1).End(xlUp).Row
    lRow1 = [Sheet3].Cells(Rows.Count, 1).End(xlUp).Row   1
    
    [Sheet2].Range("A4:N" & lRow).Copy
    [Sheet3].Range("A" & lRow1).PasteSpecial xlPasteValues
        
    Application.CutCopyMode = False
        
    Sheet3.Select
    [Sheet3].Range("A1").Select
    Sheet2.Select
    [Sheet2].Range("A1").Select
          
End Sub

CodePudding user response：

Something like this should work fine:

For r = 2 To l
    If Evaluate("COUNTIFS(A:A,A" & r & ",B:B,B" & r & ",C:C,C" & r & ")") > 1 Then
        msg = msg & vbCr & r
    End If
Next r

If Len(msg) > 0 Then
    MsgBox msg, vbInformation, "DUPLICATE ROWS"
    Exit Sub
End If

CodePudding user response：

Extended Formula evaluation without loops

Extending on Tim's row-wise formula evaluation a couple of tips:

Fully qualify your range references; without explicit indications VBA assumes the active sheet, which needn't be the one you have in mind.
Execute a worksheet-related evaluation for the same reason; doing so it suffices here to indicate e.g. "A:A" instead of inserting a sheet prefix "Sheet1!..." each time.

Example procedure

Option Explicit                   ' force declaration of variables on top of code module

Sub IdentifyDuplicateRows()
    With Sheet1                   ' using the project's Sheet Code(Name)
    '1. get last row & build formula
        Dim l As Long
        l = .Range("A" & Rows.Count).End(xlUp).Row
        Dim myFormula As String
        myFormula = "=IF(COUNTIFS(A:A,A2:A" & l & ",B:B,B2:B" & l & ",C:C,C2:C" & l & ")>1,""Duplicate Row "" & Row(A2:A" & l & "),"""")"
    '2. get results & write to target
        Dim results As Variant
        results = .Evaluate(myFormula)                 ' note the "."-prefix!
        With .Range("D2").Resize(UBound(results))
            .Value = results                           'write results to target
        End With
    '3. optional additional MsgBox info (see below)
    '   ...
    End With

End Sub

Note to optional message box info

If you prefer a further info via message box you could insert the following block before End With:

    '3. optional display in message box
        'filter only elements containing "Dup" (change to flat & eventually 0-based array)
        results = Application.Transpose(results)
        results = Filter(results, "Dup")   ' omitted default argument Include:=True
        'count duplicate rows and display message
        Dim cnt As Long
        cnt = UBound(results)   1
        MsgBox Join(results, vbNewLine), vbInformation, cnt & " Duplicate Rows"