Duplicate record handling?

[TheWennerWoman]

I have some data with duplicate records that I'd like to be able to loop through in VBA and make an amendment to. So

ABC
ABD
ABD
ABE
ABG
ABG
ABG

In the above data, I'd want the first ABD to be renamed ABD* and the second ABD to be renamed ABD**.

Like wise the three ABG records would become ABG*, ABG** and ABG***.

Is this do-able?

Many thanks as always.

 

[duggie33]

Something like this...

Book1
	A	B	C
1	ABC	1	ABC*
2	ABD	1	ABD*
3	ABD	2	ABD**
4	ABE	1	ABE*
5	ABG	1	ABG*
6	ABG	2	ABG**
7	ABG	3	ABG***
Sheet1

Cell Formulas
Range	Formula
B1:B7	B1	=COUNTIF($A$1:$A1,A1)
C1:C7	C1	=A1&REPT("*",B1)

Hope that helps,

Doug

 

[Fluff]

Another option

Fluff.xlsm
	A	B
1
2	ABC	ABC*
3	ABD	ABD*
4	ABD	ABD**
5	ABE	ABE*
6	ABG	ABG*
7	ABG	ABG**
8	ABG	ABG***
Data

Cell Formulas
Range	Formula
B2:B8	B2	=A2&REPT("*",COUNTIFS(A$2:A2,A2))

 

[Alex Blakenburg]

Since you did mention VBA and your previous posts seem to revolve aroundVBA, here is another option.
(Assumes data starts at row one and output is to Column B)

Sub AddWildCardToDups()

    Dim shtData As Worksheet
    Dim rngData As Range, arrData As Variant
    Dim lrData As Long, i As Long
    Dim dictData As Object, dictKey As String

    Set dictData = CreateObject("Scripting.dictionary")
    
    Set shtData = ActiveSheet               ' <--- Change as required
    With shtData
        lrData = .Range("A" & Rows.Count).End(xlUp).Row
        Set rngData = .Range(.Cells(1, "A"), .Cells(lrData, "A"))
        arrData = rngData.Value
        ReDim Preserve arrData(1 To UBound(arrData), 1 To 2)
    End With
    
    For i = 1 To UBound(arrData)
        dictKey = arrData(i, 1)
        If Not dictData.exists(dictKey) Then
            dictData(dictKey) = 1
            arrData(i, 2) = arrData(i, 1) & String(dictData(dictKey), "*")
        Else
            dictData(dictKey) = dictData(dictKey) + 1
              arrData(i, 2) = arrData(i, 1) & String(dictData(dictKey), "*")
        End If
    Next i
    
    ' Write back updated data
    rngData.Offset(, 1).Value = Application.Index(arrData, 0, 2)

End Sub

 

[TheWennerWoman]

Since you did mention VBA and your previous posts seem to revolve aroundVBA, here is another option.
(Assumes data starts at row one and output is to Column B)

Sub AddWildCardToDups()

    Dim shtData As Worksheet
    Dim rngData As Range, arrData As Variant
    Dim lrData As Long, i As Long
    Dim dictData As Object, dictKey As String

    Set dictData = CreateObject("Scripting.dictionary")
  
    Set shtData = ActiveSheet               ' <--- Change as required
    With shtData
        lrData = .Range("A" & Rows.Count).End(xlUp).Row
        Set rngData = .Range(.Cells(1, "A"), .Cells(lrData, "A"))
        arrData = rngData.Value
        ReDim Preserve arrData(1 To UBound(arrData), 1 To 2)
    End With
  
    For i = 1 To UBound(arrData)
        dictKey = arrData(i, 1)
        If Not dictData.exists(dictKey) Then
            dictData(dictKey) = 1
            arrData(i, 2) = arrData(i, 1) & String(dictData(dictKey), "*")
        Else
            dictData(dictKey) = dictData(dictKey) + 1
              arrData(i, 2) = arrData(i, 1) & String(dictData(dictKey), "*")
        End If
    Next i
  
    ' Write back updated data
    rngData.Offset(, 1).Value = Application.Index(arrData, 0, 2)

End Sub

That mostly works - many thanks and thanks to the other responders.

If there is only one occurrence, just leave it alone. So ABC in my sample data would stay as ABC, only duplicate records need to have a * appended.

 

[Alex Blakenburg]

I was waiting for that.

Try this:

Sub AddWildCardToDups_v02()

    Dim shtData As Worksheet
    Dim rngData As Range, arrData As Variant
    Dim lrData As Long, i As Long
    Dim dictData As Object, dictKey As String, firstID As Long

    Set dictData = CreateObject("Scripting.dictionary")
   
    Set shtData = ActiveSheet               ' <--- Change as required
    With shtData
        lrData = .Range("A" & Rows.Count).End(xlUp).Row
        Set rngData = .Range(.Cells(1, "A"), .Cells(lrData, "A"))
        arrData = rngData.Value
        ReDim Preserve arrData(1 To UBound(arrData), 1 To 2)
    End With
   
    ' Load details range into Dictionary
    For i = 1 To UBound(arrData)
        dictKey = arrData(i, 1)
        If Not dictData.exists(dictKey) Then
            firstID = -1 * i                    ' Store row ref as negative
            dictData(dictKey) = firstID
            arrData(i, 2) = arrData(i, 1)
        ElseIf dictData(dictKey) < 0 Then
            ' retrieve first occurence and add "*"
            firstID = Abs(dictData(dictKey))
            arrData(firstID, 2) = arrData(firstID, 1) & "*"
            ' 2nd occurence
            dictData(dictKey) = 2
            arrData(i, 2) = arrData(i, 1) & String(dictData(dictKey), "*")
        Else
            dictData(dictKey) = dictData(dictKey) + 1
            arrData(i, 2) = arrData(i, 1) & String(dictData(dictKey), "*")
        End If
    Next i
   
    ' Write back updated data
    rngData.Offset(, 1).Value = Application.Index(arrData, 0, 2)

End Sub

 

[TheWennerWoman]

I was waiting for that.

Try this:

Sub AddWildCardToDups_v02()

    Dim shtData As Worksheet
    Dim rngData As Range, arrData As Variant
    Dim lrData As Long, i As Long
    Dim dictData As Object, dictKey As String, firstID As Long

    Set dictData = CreateObject("Scripting.dictionary")
  
    Set shtData = ActiveSheet               ' <--- Change as required
    With shtData
        lrData = .Range("A" & Rows.Count).End(xlUp).Row
        Set rngData = .Range(.Cells(1, "A"), .Cells(lrData, "A"))
        arrData = rngData.Value
        ReDim Preserve arrData(1 To UBound(arrData), 1 To 2)
    End With
  
    ' Load details range into Dictionary
    For i = 1 To UBound(arrData)
        dictKey = arrData(i, 1)
        If Not dictData.exists(dictKey) Then
            firstID = -1 * i                    ' Store row ref as negative
            dictData(dictKey) = firstID
            arrData(i, 2) = arrData(i, 1)
        ElseIf dictData(dictKey) < 0 Then
            ' retrieve first occurence and add "*"
            firstID = Abs(dictData(dictKey))
            arrData(firstID, 2) = arrData(firstID, 1) & "*"
            ' 2nd occurence
            dictData(dictKey) = 2
            arrData(i, 2) = arrData(i, 1) & String(dictData(dictKey), "*")
        Else
            dictData(dictKey) = dictData(dictKey) + 1
            arrData(i, 2) = arrData(i, 1) & String(dictData(dictKey), "*")
        End If
    Next i
  
    ' Write back updated data
    rngData.Offset(, 1).Value = Application.Index(arrData, 0, 2)

End Sub

Genius, thank you so much, works perfectly

 

[Alex Blakenburg]

Thanks for letting us know. Glad we could help.