VBA Code Found duplicates in Two Columns in number them

[khikha1]

dear all

long time , hope this finds you well ,
please need your help with a VBA code to find duplicates , i have sheet of two columns , the first is item numbers and the second is description with numbers.
as per attached pictures i highlighted some items with same colors in columns A that i found in column B , e.g colour blue , the second item is found in column B so i highlited both in Blue and put in column C same number for them and so on...
would like a VBA code to so this please
thanks in advance .

regards
Ziad alsayed.

 

[khikha1]

dear all

long time , hope this finds you well ,
please need your help with a VBA code to find duplicates , i have sheet of two columns , the first is item numbers and the second is description with numbers.
as per attached pictures i highlighted some items with same colors in columns A that i found in column B , e.g colour blue , the second item is found in column B so i highlighted both in Blue and put in column C same number for them and so on...
would like a VBA code to so this please
thanks in advance .

regards
Ziad alsayed.

dear all

please need your assistance with this .
thanks in advance

regards
Ziad alsayed

 

[Snakehips]

@khikha1 if your data set is not too large then maybe this will do the numbering/

Sub Ziad()
Dim Arng As Range
Dim Brng As Range
Dim Num As Long
Dim lr As Long
Dim Inc As Boolean
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
lr = Range("A" & Rows.Count).End(xlUp).Row
Num = 1
Set Arng = Range("A2:A" & lr)
Set Brng = Range("B2:B" & lr)
For Each Acell In Arng
If Inc = True Then
Num = Num + 1
Inc = False
End If
    For Each Bcell In Brng
        If InStr(Bcell, Acell) Then
        Inc = True
        Acell.Offset(0, 2) = Num
        Bcell.Offset(0, 1) = Num
        Exit For  '<<*********  Delete ithis line if there may be MORE that just 1 matching per number in A
        End If
    Next Bcell
    
Next Acell
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True


End Sub

 

[khikha1]

th

@khikha1 if your data set is not too large then maybe this will do the numbering/

Sub Ziad()
Dim Arng As Range
Dim Brng As Range
Dim Num As Long
Dim lr As Long
Dim Inc As Boolean
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
lr = Range("A" & Rows.Count).End(xlUp).Row
Num = 1
Set Arng = Range("A2:A" & lr)
Set Brng = Range("B2:B" & lr)
For Each Acell In Arng
If Inc = True Then
Num = Num + 1
Inc = False
End If
    For Each Bcell In Brng
        If InStr(Bcell, Acell) Then
        Inc = True
        Acell.Offset(0, 2) = Num
        Bcell.Offset(0, 1) = Num
        Exit For  '<<*********  Delete ithis line if there may be MORE that just 1 matching per number in A
        End If
    Next Bcell
   
Next Acell
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True


End Sub

thank you , it is working perfectly .

 

[smozgur]

thank you , it is working perfectly .

The marked solution has been changed accordingly. In your future questions, please mark the post as the solution that actually answered your question, instead of your feedback message as it will help future readers. No further action is required for this thread.