Home » excel » Renaming duplicating values in Excel with VBA

# Renaming duplicating values in Excel with VBA

Questions:

I have an Excel database with the following structure:

• Unique groups: each may have several entries but their numbers are unique
• Subgroups: may have the same numbers within groups but never between the groups

I need to rename those subgroups that are repeated between different groups.

I could use nested IF formula, but the number of entries in groups and subgroups may differ a lot. So far I haven’t managed to construct a working nested loop.

here’s a NOT-VBA solution with a nested IF array formula:

1. in cell C2 type

``````=CONCATENATE(
IF(COUNTIFS(A\$2:A\$12,CONCATENATE("<>",A2),B\$2:B\$12,B2)=0,
B2,
IF(COUNTIFS(A1:A\$2,A2,B1:B\$2,B2)=0,
B2 & "-" & IF(COUNTIF(B1:B\$2,B2)=0,
1,
RIGHT(OFFSET(B\$1,LARGE(IF(B1:B\$2=B2,ROW(B1:B\$2),""),1)-1,1),
LEN(OFFSET(B\$1,LARGE(IF(B1:B\$2=B2,ROW(B1:B\$2),""),1)-1,1)) -
FIND("-",OFFSET(B\$1,LARGE(IF(B1:B\$2=B2,ROW(B1:B\$2),""),1)-1,1))
)+1
),
OFFSET(B\$1,LARGE(IF(B1:B\$2=B2,IF(A1:A\$2=A2,ROW(B1:B\$2),""),""),1)-1,1))
)
)
``````
2. press CTRL-ALT-Return to input it as an array-formula

3. copy the formula in C2 and paste it form C3 downwards

Here is a dictionary-based approach that you should be able to tweak:

``````Sub LabelSubgroups(R As Range)
'R is assumed to be a 3-column range
'Consisting of the data without the header as well as the
'final column to contain the results
'Note that the final column will be overwritten

Dim i As Long, j As Long, n As Long
Dim key1 As Variant, key2 As Variant
Dim D As Object, Grp As Object
Dim A As Variant

n = R.Rows.Count
A = R.Value
Set D = CreateObject("Scripting.Dictionary")

For i = 1 To n
key1 = A(i, 2)
key2 = A(i, 1)
If D.Exists(key1) Then
If Not D(key1).Exists(key2) Then
D(key1).Add key2, D(key1).Count + 1
End If
Else
Set Grp = CreateObject("Scripting.Dictionary")
End If
Next i

For i = 1 To n
key1 = A(i, 2)
If D(key1).Count > 1 Then
key2 = A(i, 1)
A(i, 3) = key1 & "-" & D(key1)(key2)
Else
A(i, 3) = key1
End If
Next i

R.Value = A
End Sub
``````

If you run `LabelSubgroups Range("A2:C12")` on your sample data then it produces the desired output.