Home » excel » Renaming duplicating values in Excel with VBA

Renaming duplicating values in Excel with VBA

Posted by: admin May 14, 2020 Leave a comment

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.

enter image description here

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.

How to&Answers:

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

Answer:

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")
            Grp.Add key2, 1
            D.Add key1, Grp
        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.