Excel VBA Code to find duplicate, insert incremental number and update if previous duplicate is removed

D

danieldang

New Member
Joined
Apr 27, 2023
Messages
3
Office Version
  1. 2021
Platform
  1. Windows
Dear all,
I am very new to Excel VBA, I am creating the table for a purpose and will use the table for about 9 months each year.
As you can see in the attached photo, I have a list of teams and players. The players is listed in the range B6:G20.
Some of the names have number followed which indicates the duplicate and the order of cell data update.
As of now, all the information in the table is entered manually by me including duplications.
Now I want to write a VBA code to find the duplicate executing right after I update I cell. If the duplicate is found, insert incremental number after the name and most important, update the duplicate cell if previous duplicate is removed.
For example, I enter "Haaland" in cell D18, then I enter "Haaland" again in cell F18. After I finish entering, the VBA code will run automatically and find duplication in cell D18 and cell F18. Because the information in cell D18 is updated first, then the information in cell F18 will be changed into "Haaland 2".
Again, I enter "Haaland" again in cell E20. After I finish entering, the VBA code will run automatically and find duplication in cell D18, cell F18 and cell E20. Because the information in cell D18 is updated first, the information in cell F18 is updated second, then the information in cell E20 will be changed into "Haaland 3".
Now if I remove any "Haaland" in cell D18 or F18, the incremental number of E20 should be decrease.
I don't even know if VBA code can do this or not so please help me.
Thank you so much.
If anything is unclear, feel free to leave a comment and I will explain in detailed.
 

Attachments

  • Capture.JPG
    Capture.JPG
    157 KB · Views: 39

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Sort by date Sort by votes
(Xin chào Dang, bạn là người Việt chính hiệu hay Việt Kiều? Kakaka, đùa chút, mình cũng Việt Nam đây.)
Welcome to the forum.
Back to your requirement
Yes, VBA can do it.
Could you post mini sheet, via XL2BB?
www.mrexcel.com

XL2BB - Excel Range to BBCode

Excel 'mini-sheet' in messages - XL2BB Although experts prefer to read your description and question instead of working in your actual file to solve your problem, there are times that it is difficult to explain an issue without providing actual...
www.mrexcel.com www.mrexcel.com
 
Upvote 0
Hi @danieldang. Welcome to the MrExcel forum. Please accept my warmest greetings and sincere hope that all is well.

I think I have it.
You should test all possible scenarios.

The macro considers the following:
1. You can't capture the consecutive number, that's what the macro does.
2. Examples: If you first capture "Tom" first time, nothing happens.
3. If you capture "Tom" a second time, then they are numbered "Tom 1" and "Tom 2" in the order they were captured.
4. If you capture "Tom" for the third time, then it is numbered as "Tom 3" .
5. If you capture "Ana", first time, nothing happens.
6. If you capture "Tom" for the fourth time, then it is numbered as "Tom 4" .
7. If you capture "Ana" replacing "Tom 2", then the "Ana" are numbered "Ana 1" and "Ana 2" in the order they were captured. And, the "Tom" is left as "Tom 1", "Tom 2" and "Tom 3" (in the order they were captured).
8. If you delete "Tom 2", then "Tom 1" remains and "Tom 3" becomes "Tom 2".

Put the following code in your sheet events where you want this to happen.
VBA Code: 
Option Explicit

Dim players As New Collection
Dim playadd As New Collection

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng As Range, f As Range, c As Range
  Dim num As Long, nmax As Long, i As Long
  Dim prefix As String, sNew As String, sPre As String
  Dim itms As Variant, p As Variant
  Dim b As Variant, consecutive As Long
  
  Set rng = Range("B6:G20")
  ReDim b(1 To rng.Cells.Count, 1 To 2)
  If Not Intersect(Target, rng) Is Nothing Then
    If Target.Count > 1 Then Exit Sub
    If IsNumeric(Right(Target.Value, 1)) Then
      MsgBox "You can't capture numbers, the macro will insert them"
      Application.EnableEvents = False
      Target.Value = ""
      Target.Select
      Application.EnableEvents = True
      Exit Sub
    End If
    
    If Target.Value = "" Then
      Application.EnableEvents = False
      sNew = Target.Value
      Application.Undo
      sPre = Target.Value
      Target.Value = sNew
      Application.EnableEvents = True
      
      'FOR THE PREVIOUS
      If sPre <> "" Then
        Call correct_numbering(sPre, rng, Target)
      End If
      
    Else
    
      Application.EnableEvents = False
      sNew = Target.Value
      Application.Undo
      sPre = Target.Value
      Target.Value = sNew
      Application.EnableEvents = True
      
      'FOR THE NEW
      prefix = Target.Value
      For Each c In rng
        If c.Address <> Target.Address Then
          If Left(c.Value, Len(Target.Value)) = prefix Then
            If Len(c.Value) = Len(Target.Value) Then
              Application.EnableEvents = False
                c.Value = c.Value & " " & 1
                Target.Value = Target.Value & " " & 2
              Application.EnableEvents = True
            Else
              num = Mid(c.Value, Len(Target.Value) + 1)
              If num > nmax Then nmax = num
            End If
          End If
        End If
      Next
      If nmax > 0 Then
        Application.EnableEvents = False
          Range(Target.Address).Value = prefix & " " & nmax + 1
        Application.EnableEvents = True
      End If
      
      'FOR THE PREVIOUS
      If sPre <> "" Then
        Call correct_numbering(sPre, rng, Target)
      End If
    End If  'target <> ""
  End If  'intersect
  Set players = Nothing
  Set playadd = Nothing
End Sub

Sub adding(itm, adr)
  Dim i As Long
  For i = 1 To players.Count
    Select Case StrComp(players(i), itm, vbTextCompare)
      Case 0: Exit Sub
      Case 1
        players.Add itm, Before:=i
        playadd.Add adr, Before:=i: Exit Sub
    End Select
  Next
  players.Add itm
  playadd.Add adr
End Sub

Sub correct_numbering(sPre, rng, Target)
  Dim consecutive As Long, num As Long
  Dim c As Range
  Dim itms As Variant
  Dim prefix As String
  Dim i As Long
  
  itms = Split(sPre, " ")
  If Not IsNumeric(itms(UBound(itms))) Then Exit Sub
  num = itms(UBound(itms))
  prefix = Trim(Left(sPre, Len(sPre) - Len(CStr(num))))

  For Each c In rng
    If c.Address <> Target.Address And c.Value <> "" Then
      If Left(c.Value, Len(prefix)) = prefix Then
        Call adding(c.Value, c.Address)
      End If
    End If
  Next
  
  If players.Count = 1 Then
    Application.EnableEvents = False
    Range(playadd(1)).Value = prefix
    Application.EnableEvents = True
  Else
    For i = 1 To players.Count
      itms = Split(players(i), " ")
      consecutive = itms(UBound(itms))
      If consecutive > num Then
        Application.EnableEvents = False
        consecutive = consecutive - 1
        Range(playadd(i)).Value = prefix & " " & consecutive
        Application.EnableEvents = True
      End If
    Next
  End If
End Sub
Note Sheet Event: Right click the tab of the sheet you want this to work, select view code and paste the code into the window that opens up.
Return to the sheet and automatically the macro will be executed when you modify any of the cells in the range "B6:G20".


If something doesn't work the way you need it, describe that scenario step by step, so that I can replicate it and make the correction.


--------------
I hope to hear from you soon.
Respectfully
Dante Amor
--------------
 
Upvote 0
Solution
bebo021999 said:
(Xin chào Dang, bạn là người Việt chính hiệu hay Việt Kiều? Kakaka, đùa chút, mình cũng Việt Nam đây.)
Welcome to the forum.
Back to your requirement
Yes, VBA can do it.
Could you post mini sheet, via XL2BB?
www.mrexcel.com

XL2BB - Excel Range to BBCode

Excel 'mini-sheet' in messages - XL2BB Although experts prefer to read your description and question instead of working in your actual file to solve your problem, there are times that it is difficult to explain an issue without providing actual...
www.mrexcel.com www.mrexcel.com
Click to expand...
Hà Nội chính gốc bạn :D có ông bạn ở dưới giúp rùi, để tui thử code xem. Cảm ơn nhé
 
Upvote 0
DanteAmor said:
Hi @danieldang. Welcome to the MrExcel forum. Please accept my warmest greetings and sincere hope that all is well.

I think I have it.
You should test all possible scenarios.

The macro considers the following:
1. You can't capture the consecutive number, that's what the macro does.
2. Examples: If you first capture "Tom" first time, nothing happens.
3. If you capture "Tom" a second time, then they are numbered "Tom 1" and "Tom 2" in the order they were captured.
4. If you capture "Tom" for the third time, then it is numbered as "Tom 3" .
5. If you capture "Ana", first time, nothing happens.
6. If you capture "Tom" for the fourth time, then it is numbered as "Tom 4" .
7. If you capture "Ana" replacing "Tom 2", then the "Ana" are numbered "Ana 1" and "Ana 2" in the order they were captured. And, the "Tom" is left as "Tom 1", "Tom 2" and "Tom 3" (in the order they were captured).
8. If you delete "Tom 2", then "Tom 1" remains and "Tom 3" becomes "Tom 2".

Put the following code in your sheet events where you want this to happen.
VBA Code: 
Option Explicit

Dim players As New Collection
Dim playadd As New Collection

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng As Range, f As Range, c As Range
  Dim num As Long, nmax As Long, i As Long
  Dim prefix As String, sNew As String, sPre As String
  Dim itms As Variant, p As Variant
  Dim b As Variant, consecutive As Long
 
  Set rng = Range("B6:G20")
  ReDim b(1 To rng.Cells.Count, 1 To 2)
  If Not Intersect(Target, rng) Is Nothing Then
    If Target.Count > 1 Then Exit Sub
    If IsNumeric(Right(Target.Value, 1)) Then
      MsgBox "You can't capture numbers, the macro will insert them"
      Application.EnableEvents = False
      Target.Value = ""
      Target.Select
      Application.EnableEvents = True
      Exit Sub
    End If
   
    If Target.Value = "" Then
      Application.EnableEvents = False
      sNew = Target.Value
      Application.Undo
      sPre = Target.Value
      Target.Value = sNew
      Application.EnableEvents = True
     
      'FOR THE PREVIOUS
      If sPre <> "" Then
        Call correct_numbering(sPre, rng, Target)
      End If
     
    Else
   
      Application.EnableEvents = False
      sNew = Target.Value
      Application.Undo
      sPre = Target.Value
      Target.Value = sNew
      Application.EnableEvents = True
     
      'FOR THE NEW
      prefix = Target.Value
      For Each c In rng
        If c.Address <> Target.Address Then
          If Left(c.Value, Len(Target.Value)) = prefix Then
            If Len(c.Value) = Len(Target.Value) Then
              Application.EnableEvents = False
                c.Value = c.Value & " " & 1
                Target.Value = Target.Value & " " & 2
              Application.EnableEvents = True
            Else
              num = Mid(c.Value, Len(Target.Value) + 1)
              If num > nmax Then nmax = num
            End If
          End If
        End If
      Next
      If nmax > 0 Then
        Application.EnableEvents = False
          Range(Target.Address).Value = prefix & " " & nmax + 1
        Application.EnableEvents = True
      End If
     
      'FOR THE PREVIOUS
      If sPre <> "" Then
        Call correct_numbering(sPre, rng, Target)
      End If
    End If  'target <> ""
  End If  'intersect
  Set players = Nothing
  Set playadd = Nothing
End Sub

Sub adding(itm, adr)
  Dim i As Long
  For i = 1 To players.Count
    Select Case StrComp(players(i), itm, vbTextCompare)
      Case 0: Exit Sub
      Case 1
        players.Add itm, Before:=i
        playadd.Add adr, Before:=i: Exit Sub
    End Select
  Next
  players.Add itm
  playadd.Add adr
End Sub

Sub correct_numbering(sPre, rng, Target)
  Dim consecutive As Long, num As Long
  Dim c As Range
  Dim itms As Variant
  Dim prefix As String
  Dim i As Long
 
  itms = Split(sPre, " ")
  If Not IsNumeric(itms(UBound(itms))) Then Exit Sub
  num = itms(UBound(itms))
  prefix = Trim(Left(sPre, Len(sPre) - Len(CStr(num))))

  For Each c In rng
    If c.Address <> Target.Address And c.Value <> "" Then
      If Left(c.Value, Len(prefix)) = prefix Then
        Call adding(c.Value, c.Address)
      End If
    End If
  Next
 
  If players.Count = 1 Then
    Application.EnableEvents = False
    Range(playadd(1)).Value = prefix
    Application.EnableEvents = True
  Else
    For i = 1 To players.Count
      itms = Split(players(i), " ")
      consecutive = itms(UBound(itms))
      If consecutive > num Then
        Application.EnableEvents = False
        consecutive = consecutive - 1
        Range(playadd(i)).Value = prefix & " " & consecutive
        Application.EnableEvents = True
      End If
    Next
  End If
End Sub
Note Sheet Event: Right click the tab of the sheet you want this to work, select view code and paste the code into the window that opens up.
Return to the sheet and automatically the macro will be executed when you modify any of the cells in the range "B6:G20".


If something doesn't work the way you need it, describe that scenario step by step, so that I can replicate it and make the correction.


--------------
I hope to hear from you soon.
Respectfully
Dante Amor
--------------
Click to expand...
Dear Dante,
The code works perfectly in my case.
But there is a smaller problem is that I want to share the workbook for my friend so that they can see and update the status of the players.
There are 2 ways to do that. The first is Excel Webapp which I don't use and the second is Google Sheets.
I know that both platform does not support VBA but JavaScript, in Google case it is called Google App Scripts.
I have looked for a way to convert the VBA code to JavaScript but nothing works until now.
So I am really hopeful that you will help me with this smaller problem.
Excel Webapp or Google Sheet is not important because I can use whichever platform that the Javascript code works.
Thank you so so much,
Your friend,
Daniel Dang
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question Question
Remove Duplicates from previous or multiple sheets.
Replies
7
Views
187
Benji3899
B
O
  • Solved
VBA Code to Find Duplicate Values in a Range and Add a Number at the End
2
Replies
12
Views
633
OilEconomist
O
C
  • Solved
VBA - Checking for Duplicates
Replies
2
Views
824
cwhaley1
C
M
  • Solved
Insert new row with incremental formula
Replies
8
Views
540
Sheik
S
C
  • Solved
VBA Check for duplicate value and change if duplicate.
Replies
7
Views
478
Alex Blakenburg
A

Forum statistics

Threads
1,223,638
Messages
6,173,492
Members
452,516
Latest member
druck21

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top