VBA Check for duplicate value and change if duplicate.

[CharlieDP]

Dear all, I am a new user of Excel VBA and try to use it to automize the daily working routine. Now I'm facing the problem of checking duplication and change the value.

So basically what I would like to do is to check the order for customers and I would like to check whether there are duplicate by checking customers' name appeared in the list of order records. If there are duplication I would like to check whether they require different items. If yes I will assign -n, which n equals to the number of times the order has duplicated, at the end of the order number to identify same customers with different orders.

Here is the code that I would like to use for achieving my needs,

Dim Sht As Worksheet
Set Sht = Worksheets
Set Dict = CreateObject("Scripting.Dictionary")

For x = 2 To LastRow

Do While Len(Sht.Cells(x, "B")) > 0
If Dict.Exists(CStr(Sht.Cells(x, "B"))) = False Then
Dict.Add CStr(Sht.Cells(x, "B")), x
Else
Cells(x, "B").Value = Cells(x, "B").Value & "-B"
Cells(x - 1, "B").Value = Cells(x - 1, "B").Value & "-A"
End If

x = x + 1
Loop
Next x

The problems that the code did not fulfill my requirement is that the duplicated data does not always stay together so I cannot simply just use x - 1 to achieve the order number modification. It is incapable to change the order number if there are more than 2 orders required from the same customers. I' not using customers requirement as a filter to check whether it is "Duplicated customers name different customers requirement" scenario as well.


The sample of the table has been attached in terms of mini-sheet for your reference. Thank you very much if you can response to this question and it's ok if you cannot. Just study with me together for advance VBA skills. I wish you all the best.

asking.xlsx
	A	B	C	D
1	Order Date	Order Number	Customers	Customers Requirement
2	13/5/2024	AABBBBCCC	Mark	Pen
3	13/5/2024	AACCCCDDD	Jack	Cup
4	13/5/2024	AADDDDEEE	Frank	Ruler
5	13/5/2024	AABBBBCCC	Mark	Ruler
工作表1

 

[Alex Blakenburg]

See if this does what you are after:

Sub AddOrderItemNo()

    Dim Sht As Worksheet
    Dim rngData As Range, arrData As Variant
    Dim rowLast As Long, Order1st As Long, nextNo As Long
    Dim dictData As Object, dictKey As String
    Dim i As Long
    
    Set Sht = ActiveSheet
    With Sht
        rowLast = .Range("B" & Rows.Count).End(xlUp).Row
        Set rngData = .Range(.Cells(2, "A"), .Cells(rowLast, "D"))
        arrData = rngData.Value2
    End With
    
    Set dictData = CreateObject("Scripting.Dictionary")
    
    ' Load details range into Dictionary
    For i = 1 To UBound(arrData)
        dictKey = arrData(i, 2)
        If Not dictData.exists(dictKey) Then
            dictData(dictKey) = -i
        ElseIf dictData(dictKey) < 0 Then
            nextNo = 1
            Order1st = -dictData(dictKey)
            arrData(Order1st, 2) = arrData(Order1st, 2) & "-" & nextNo
            nextNo = 2
            dictData(dictKey) = nextNo
            arrData(i, 2) = arrData(i, 2) & "-" & nextNo
        Else
            nextNo = dictData(dictKey) + 1
            dictData(dictKey) = nextNo
            arrData(i, 2) = arrData(i, 2) & "-" & nextNo
        End If
    Next i
    
    rngData.Columns(2).Value = Application.Index(arrData, 0, 2)
    rngData.Columns(2).AutoFit

End Sub

 

[CharlieDP]

See if this does what you are after:

Sub AddOrderItemNo()

    Dim Sht As Worksheet
    Dim rngData As Range, arrData As Variant
    Dim rowLast As Long, Order1st As Long, nextNo As Long
    Dim dictData As Object, dictKey As String
    Dim i As Long
   
    Set Sht = ActiveSheet
    With Sht
        rowLast = .Range("B" & Rows.Count).End(xlUp).Row
        Set rngData = .Range(.Cells(2, "A"), .Cells(rowLast, "D"))
        arrData = rngData.Value2
    End With
   
    Set dictData = CreateObject("Scripting.Dictionary")
   
    ' Load details range into Dictionary
    For i = 1 To UBound(arrData)
        dictKey = arrData(i, 2)
        If Not dictData.exists(dictKey) Then
            dictData(dictKey) = -i
        ElseIf dictData(dictKey) < 0 Then
            nextNo = 1
            Order1st = -dictData(dictKey)
            arrData(Order1st, 2) = arrData(Order1st, 2) & "-" & nextNo
            nextNo = 2
            dictData(dictKey) = nextNo
            arrData(i, 2) = arrData(i, 2) & "-" & nextNo
        Else
            nextNo = dictData(dictKey) + 1
            dictData(dictKey) = nextNo
            arrData(i, 2) = arrData(i, 2) & "-" & nextNo
        End If
    Next i
   
    rngData.Columns(2).Value = Application.Index(arrData, 0, 2)
    rngData.Columns(2).AutoFit

End Sub

Appreciate for your help but I have a question. If I would like to assign letters rather than numbers in the end of order no how can I do so?

 

[Alex Blakenburg]

Can we rely on the no of lines per order not exceeding 26 ?

 

[CharlieDP]

Alex Blakenburg​

Yes. 26 lines have enough capacity for the current situation.

 

[Alex Blakenburg]

This is only good for up to Z

Sub AddOrderItemNo_Letter()

    Dim Sht As Worksheet
    Dim rngData As Range, arrData As Variant
    Dim rowLast As Long, Order1st As Long, nextNo As Long, nextLetter As String
    Dim dictData As Object, dictKey As String
    Dim i As Long
    
    Set Sht = ActiveSheet
    With Sht
        rowLast = .Range("B" & Rows.Count).End(xlUp).Row
        Set rngData = .Range(.Cells(2, "A"), .Cells(rowLast, "D"))
        arrData = rngData.Value2
    End With
    
    Set dictData = CreateObject("Scripting.Dictionary")
    
    ' Load details range into Dictionary
    For i = 1 To UBound(arrData)
        dictKey = arrData(i, 2)
        If Not dictData.exists(dictKey) Then
            dictData(dictKey) = -i
        ElseIf dictData(dictKey) < 0 Then
            nextNo = 1
            nextLetter = Chr(nextNo + 64)
            Order1st = -dictData(dictKey)
            arrData(Order1st, 2) = arrData(Order1st, 2) & "-" & nextLetter
            nextNo = 2
            nextLetter = Chr(nextNo + 64)
            dictData(dictKey) = nextNo
            arrData(i, 2) = arrData(i, 2) & "-" & nextLetter
        Else
            nextNo = dictData(dictKey) + 1
            dictData(dictKey) = nextNo
            nextLetter = Chr(nextNo + 64)
            arrData(i, 2) = arrData(i, 2) & "-" & nextLetter
        End If
    Next i
    
    rngData.Columns(2).Value = Application.Index(arrData, 0, 2)
    rngData.Columns(2).AutoFit

End Sub

 

[CharlieDP]

This is only good for up to Z

Sub AddOrderItemNo_Letter()

    Dim Sht As Worksheet
    Dim rngData As Range, arrData As Variant
    Dim rowLast As Long, Order1st As Long, nextNo As Long, nextLetter As String
    Dim dictData As Object, dictKey As String
    Dim i As Long
   
    Set Sht = ActiveSheet
    With Sht
        rowLast = .Range("B" & Rows.Count).End(xlUp).Row
        Set rngData = .Range(.Cells(2, "A"), .Cells(rowLast, "D"))
        arrData = rngData.Value2
    End With
   
    Set dictData = CreateObject("Scripting.Dictionary")
   
    ' Load details range into Dictionary
    For i = 1 To UBound(arrData)
        dictKey = arrData(i, 2)
        If Not dictData.exists(dictKey) Then
            dictData(dictKey) = -i
        ElseIf dictData(dictKey) < 0 Then
            nextNo = 1
            nextLetter = Chr(nextNo + 64)
            Order1st = -dictData(dictKey)
            arrData(Order1st, 2) = arrData(Order1st, 2) & "-" & nextLetter
            nextNo = 2
            nextLetter = Chr(nextNo + 64)
            dictData(dictKey) = nextNo
            arrData(i, 2) = arrData(i, 2) & "-" & nextLetter
        Else
            nextNo = dictData(dictKey) + 1
            dictData(dictKey) = nextNo
            nextLetter = Chr(nextNo + 64)
            arrData(i, 2) = arrData(i, 2) & "-" & nextLetter
        End If
    Next i
   
    rngData.Columns(2).Value = Application.Index(arrData, 0, 2)
    rngData.Columns(2).AutoFit

End Sub

Alex Blakenburg

Appreciate for you help. A-Z is way more than enough for my case. Wish you all the best!

 

[Alex Blakenburg]

You're welcome. Glad I could help.