Find duplicates to show in MsgBox

[MagnusGrey]

Hi All,

I have this problem for a while now, I'm trying to count the duplicates by the last 2 digits of data in 1 column using this formula "=0+(COUNTIF(R2C[-6]:R10000C[-6],RIGHT(RC[-6],2)&""*"")>1)" but it doesn't make the count.

What I'm trying to do is a macro that shows in a MsgBox the 2 digits number with their respective duplicate count for example
40 = 4
54 = 2

8546
9540
4540
4543
8054
5444
6254
9540
5440
5490
5435
5458

<colgroup><col width="64" style="width: 48pt;"> <tbody> </tbody>

 

[igold]

Hi,

There is probably a more eloquent way of doing this, but this does work. The code assumes that your numbers are in Column A starting in Cell A1.

Sub fndDupes()
    Dim dupcol
    Dim lRow As Long, i As Long, ct As Long
    Dim x As Integer
    Dim res As String
    
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    dupcol = Range("A1:A" & lRow)
    For x = 10 To 99
        For i = LBound(dupcol) To UBound(dupcol)
            If Val(Right(dupcol(i, 1), 2)) = x Then
                ct = ct + 1
            End If
        Next
        If ct >= 2 Then
            res = res & x & " = " & ct & vbNewLine
        End If
        ct = 0
    Next
    MsgBox res
    
End Sub

HTH

 

[igold]

I just realized that I did not account for 01-09. You can change this line:

For x = 10 to 99

to

For x = 1 to 99

The results will still be accurate but the format in the message box does not display the leading zero in the 01-09 range of duplicates.

Sorry about the confusion...

 

[Trebor76]

Here's my attempt:

Option Explicit
Sub Macro2()

    Dim rngMyCell As Range
    Dim rngMyRange As Range
    Dim rngMyRecord As Range
    Dim intMyCount As Integer
    Dim strMyText As String
    Dim objMyUniqueValues As Object
    
    Application.ScreenUpdating = False
    
    'Sets the range from cell A2 down to the last row in Col. A. Change yto suit.
    Set rngMyRange = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
    
    Set objMyUniqueValues = CreateObject("Scripting.Dictionary")
    
    For Each rngMyCell In rngMyRange
        intMyCount = 1
        'If the right two characters are not in the 'objMyUniqueValues' array, then...
        If objMyUniqueValues.Exists(CStr(Right(rngMyCell, 2))) = False Then
            objMyUniqueValues.Add CStr(Right(rngMyCell, 2)), Right(rngMyCell, 2)
            '...count how many times they appear in the list, excluding the active cell
            For Each rngMyRecord In rngMyRange
                If rngMyRecord.Address <> rngMyCell.Address Then
                    If Val(Right(rngMyRecord, 2)) = Val(Right(rngMyCell, 2)) Then
                        intMyCount = intMyCount + 1
                    End If
                End If
            Next rngMyRecord
            If intMyCount > 1 Then
               If strMyText = "" Then
                   strMyText = Val(Right(rngMyCell, 2)) & " = " & intMyCount
               Else
                   strMyText = strMyText & vbNewLine & Val(Right(rngMyCell, 2)) & " = " & intMyCount
               End If
            End If
        End If
    Next rngMyCell
    
    Application.ScreenUpdating = True
    
    MsgBox strMyText
    
End Sub

Regards,

Robert

 

[igold]

@Robert,

Out of curiosity I ran both codes on 100,000 records. Times were identical at about 6.75 seconds each, on my machine...

Regards,

igold

 

[Marcelo Branco]

Another code
Assumes data in column A beginning in row 2

Sub aTest()
    Dim dic As Object, vData As Variant, strMsg As String
    Dim i As Long, vKey As Variant
    
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = vbTextCompare
    
    vData = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
    For i = LBound(vData, 1) To UBound(vData, 1)
        If vData(i, 1) <> "" Then dic(Right(vData(i, 1), 2)) = dic(Right(vData(i, 1), 2)) + 1
    Next i
    
    For Each vKey In dic.keys
        If dic(vKey) > 1 Then strMsg = strMsg & vKey & " = " & dic(vKey) & Chr(10)
    Next vKey
    
    MsgBox "Duplicates" & Chr(10) & Mid(strMsg, 1, Len(strMsg) - 1)
End Sub

M.

 

[Fazza]

another version

Sub assumes_numeric_data()


  Const lCOLUMN_TO_ANALYSE As Long = 1 'column with the data


  Dim i As Long, k As Long
  Dim v As Long
  Dim ar() As Variant
  Dim input_data As Variant
  
  input_data = ActiveSheet.UsedRange.Columns(lCOLUMN_TO_ANALYSE).Value2
  ReDim ar(0 To 99)
  
  For i = LBound(input_data) To UBound(input_data)
    If Len(input_data(i, 1)) > 0 Then
      v = CLng(Right$(input_data(i, 1), 2))
      ar(v) = ar(v) + 1
    End If
  Next i
  
  For i = LBound(ar) To UBound(ar)
    If Len(ar(i)) > 0 Then
      ar(k) = i & " = " & ar(i)
      k = k + 1
    End If
  Next i
  ReDim Preserve ar(0 To k - 1)
  
  MsgBox Join$(ar, vbCr)


End Sub

 

[igold]

Hi All,

For everyone's information, I ran all the codes on 100,000 rows of data. The results are:

igold: 6.75 Seconds
Trebor76: 6.75 Seconds
Marcelo: .33 Seconds
Fazza: .10 Seconds

Of note, Marcelo is the only one that had the leading zero correctly formatted in the Message Box.

What a great example of the different ways the same task can be accomplished. I was not the OP, but thanks everyone for the education...

Kind Regards,

igold

 

[Marcelo Branco]

What a great example of the different ways the same task can be accomplished. I was not the OP, but thanks everyone for the education...

Yes, it's good to see different approaches to doing a task.
I knew my code was very fast, but Fazza did better and his code is even faster by 20 hundredths of a second.
Always learning...

M.

 

[Marcelo Branco]

Trying to understand Fazza's code, i noticed that it doesn't check whether the number of occurrences is greater than 1 (duplicates). It lists all the values (rightmost two characters) even when number of occurrences is just 1.

M.