Number duplicate values VBA

[sofas]

Welcome . I have this code to bring the values of column E to F. Numbering duplicate values in parentheses works well. I want to add a condition to fetch data provided that there is a value in column M, or ignore the numbering of duplicate values when checking that there is no corresponding value in column M.

Sub test()


Dim r As Range:         Set r = ActiveSheet.Range("E7:E" & Range("E" & Rows.Count).End(xlUp).Row)
Dim AR() As Variant:    AR = r.Value2
Dim Res() As Variant:   ReDim Res(1 To UBound(AR), 1 To 1)
With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(AR)
        If Not .Exists(AR(i, 1)) Then
            .Add AR(i, 1), 1
            Res(i, 1) = AR(i, 1)
        Else
            .Item(AR(i, 1)) = .Item(AR(i, 1)) + 1
            Res(i, 1) = AR(i, 1) & " (" & .Item(AR(i, 1)) & ")"
        End If
    Next i

        r.Offset(, 1).Value2 = Res
End With

End Sub

 

[lrobbo314]

Is this the kind of output you're after?

MXL Number Dupes.xlsm
	E	F	G	H	I	J	K	L	M
6	Data 1	Result							Data 2
7	A	A							A
8	B	B							B
9	C	C							C
10	D	D							D
11	E	E							E
12	F	F							F
13	G	G							G
14	A
15	B	B (2)							B
16	C
17	A	A (2)							A
18	B	B (3)							B
19	C	C (2)							C
20	H	H							H
21	I	I							I
22	Y	Y							Y
23	T	T							T
Sheet2

 

[sofas]

Is this the kind of output you're after?

MXL Number Dupes.xlsm
	E	F	G	H	I	J	K	L	M
6	Data 1	Result							Data 2
7	A	A							A
8	B	B							B
9	C	C							C
10	D	D							D
11	E	E							E
12	F	F							F
13	G	G							G
14	A
15	B	B (2)							B
16	C
17	A	A (2)							A
18	B	B (3)							B
19	C	C (2)							C
20	H	H							H
21	I	I							I
22	Y	Y							Y
23	T	T							T
Sheet2

Yes exactly. It is recommended that the value be copied to column (F) and ignored during numbering when cell( M )is empty. If not, this result can be used as well

 

[MicCh]

Sub test()

Dim r As Range:         Set r = ActiveSheet.Range("E7:E" & Range("E" & Rows.Count).End(xlUp).Row)
Dim AR() As Variant:    AR = r.Value2
Dim BR() As Variant:    AR = r.Offset(, 8).Value2
Dim Res() As Variant:   ReDim Res(1 To UBound(AR), 1 To 1)
With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(AR)
        If VBA.Len(BR(i, 1)) > 0 Then
        If Not .Exists(AR(i, 1)) Then
            .Add AR(i, 1), 1
            Res(i, 1) = AR(i, 1)
        Else
            .Item(AR(i, 1)) = .Item(AR(i, 1)) + 1
            Res(i, 1) = AR(i, 1) & " (" & .Item(AR(i, 1)) & ")"
        End If
        End If
    Next i

        r.Offset(, 1).Value2 = Res
End With

End Sub

 

[sofas]

Sub test()

Dim r As Range:         Set r = ActiveSheet.Range("E7:E" & Range("E" & Rows.Count).End(xlUp).Row)
Dim AR() As Variant:    AR = r.Value2
Dim BR() As Variant:    AR = r.Offset(, 8).Value2
Dim Res() As Variant:   ReDim Res(1 To UBound(AR), 1 To 1)
With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(AR)
        If VBA.Len(BR(i, 1)) > 0 Then
        If Not .Exists(AR(i, 1)) Then
            .Add AR(i, 1), 1
            Res(i, 1) = AR(i, 1)
        Else
            .Item(AR(i, 1)) = .Item(AR(i, 1)) + 1
            Res(i, 1) = AR(i, 1) & " (" & .Item(AR(i, 1)) & ")"
        End If
        End If
    Next i

        r.Offset(, 1).Value2 = Res
End With

End Sub

Excellent. I made a slight modification to the code to get the desired result. Is it possible to add that when checking the blankness of column M, the value of column E is copied to F without numbering?

 

[lrobbo314]

Give this a shot.

Sub test()
Dim r As Range:         Set r = ActiveSheet.Range("E7:E" & Range("E" & Rows.Count).End(xlUp).Row)
Dim ra As Range:        Set ra = ActiveSheet.Range("M7:M" & Range("M" & Rows.Count).End(xlUp).Row)
Dim AR() As Variant:    AR = r.Value2
Dim CO() As Variant:    CO = ra.Value2
Dim Res() As Variant:   ReDim Res(1 To UBound(AR), 1 To 1)

With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(AR)
        If Not .Exists(AR(i, 1)) And AR(i, 1) = CO(i, 1) Then
            .Add AR(i, 1), 1
            Res(i, 1) = AR(i, 1)
        ElseIf AR(i, 1) = CO(i, 1) Then
            .Item(AR(i, 1)) = .Item(AR(i, 1)) + 1
            Res(i, 1) = AR(i, 1) & " (" & .Item(AR(i, 1)) & ")"
        Else
            Res(i, 1) = AR(i, 1)
        End If
    Next i
    r.Offset(, 1).Value2 = Res
End With

End Sub

 

[sofas]

Give this a shot.

Sub test()
Dim r As Range:         Set r = ActiveSheet.Range("E7:E" & Range("E" & Rows.Count).End(xlUp).Row)
Dim ra As Range:        Set ra = ActiveSheet.Range("M7:M" & Range("M" & Rows.Count).End(xlUp).Row)
Dim AR() As Variant:    AR = r.Value2
Dim CO() As Variant:    CO = ra.Value2
Dim Res() As Variant:   ReDim Res(1 To UBound(AR), 1 To 1)

With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(AR)
        If Not .Exists(AR(i, 1)) And AR(i, 1) = CO(i, 1) Then
            .Add AR(i, 1), 1
            Res(i, 1) = AR(i, 1)
        ElseIf AR(i, 1) = CO(i, 1) Then
            .Item(AR(i, 1)) = .Item(AR(i, 1)) + 1
            Res(i, 1) = AR(i, 1) & " (" & .Item(AR(i, 1)) & ")"
        Else
            Res(i, 1) = AR(i, 1)
        End If
    Next i
    r.Offset(, 1).Value2 = Res
End With

End Sub

Thank you all for your help. I tried mixing the codes you provided me with to get the desired result, which is as follows. What I am missing now is to show an alert message that includes the values of the columns for which the command has not been executed, since the corresponding cell in column m is empty. It is stored and shown after the code is executed.

Sub test()
Dim sh As Worksheet:     Set sh = Sheet2
Dim F As Variant:            Set r = sh.Range("E7:E" & Range("E" & Rows.Count).End(xlUp).Row)
Dim arr() As Variant:        arr = r.Value2: F = r.Offset(, 8).Value2
Dim col() As Variant:        ReDim col(1 To UBound(arr), 1 To 1)
Application.ScreenUpdating = False

sh.Range("F7", Range("F" & Rows.Count).End(4)).ClearContents
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arr)
  If VBA.Len(F(i, 1)) > 0 And (arr(i, 1)) > 0 Then
        If Not .Exists(arr(i, 1)) Then
            .Add arr(i, 1), 1
            col(i, 1) = arr(i, 1)
        Else
            .Item(arr(i, 1)) = .Item(arr(i, 1)) + 1
            col(i, 1) = arr(i, 1) & " (" & .Item(arr(i, 1)) & ")"

        End If
        End If
    Next i
        r.Offset(, 1).Value2 = col
End With
Application.ScreenUpdating = True

End Sub