For Loop, If Statement, and CountIf (Cutting down run-time)

Yorke

New Member
Joined
Nov 29, 2021
Messages
19
Office Version
  1. 365
Platform
  1. Windows
Hi all,

For each cell in column B, I want to count how many cells in that column have the same value. If there is only one cell in the column with that value, change the Cell.Value to Cell.Value & "a", if there are two cells in the column with that value, change the Cell.Value to Cell.Value & "b", and so on.

This ensures each cell will have a different string, despite having the same start to the value, which should still be recognisable. The code I have written works, however it takes a really long time to run. Can anyone suggest a smarter way of writing it which will cut down on run time?

LRD = ThisWorkbook.Worksheets("Data").Range("B" & Rows.Count).End(xlUp).Row 'Endpoint of Column B in Data tab
For Each Cell In ThisWorkbook.Worksheets("Data").Range("B2:B" & LRD)
If WorksheetFunction.CountIf(ThisWorkbook.Worksheets("Data").Range("B2:B" & LRD), Cell.Value) = 1 Then Cell.Value = Cell.Value & "a"
If WorksheetFunction.CountIf(ThisWorkbook.Worksheets("Data").Range("B2:B" & LRD), Cell.Value) = 2 Then Cell.Value = Cell.Value & "b"
If WorksheetFunction.CountIf(ThisWorkbook.Worksheets("Data").Range("B2:B" & LRD), Cell.Value) = 3 Then Cell.Value = Cell.Value & "c"
If WorksheetFunction.CountIf(ThisWorkbook.Worksheets("Data").Range("B2:B" & LRD), Cell.Value) = 4 Then Cell.Value = Cell.Value & "d"
Next Cell

Background: I have a list of order numbers (i.e. 12345), sometimes the order numbers occur multiple times (i.e. 12783, 12783, 12784). I want to differentiate them so later when I VLOOKUP a corresponding value I still can pull all information, rather than just one value which may only apply to one of the order numbers. So alternatively is there another way of doing this, without renaming the order numbers?

Bonus: Is there a way to simplify the code so it would work for almost infinite amounts of identical values? The equivalent of going to "Cell.Value & "Z"" or "Cell.Value & "AF"" for example (without having to write that many lines)?

Thanks in advance!
 

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
I kind of tested this code. You may want to refine it a little. This is constantly looking above the current cell to test for duplicates. Once all the new alphabet letters have been applied it writes them back. I didn't know if you wanted the very first order number to have a letter or to be left alone.


VBA Code:
Sub Macro111()
  Dim X As Long
  Dim Cel As Range
  Dim R As Range
  Dim Alphabet As String
  Dim Cnt As Long
  Dim NewR As Range
  Dim Ary() As Variant
  Dim Sht As Worksheet
  
  Application.Calculation = xlCalculationManual
  
  Set Cel = ThisWorkbook.Worksheets("Data").Range("B100000").End(xlUp)
  Set R = ThisWorkbook.Worksheets("Data").Range("B2", Cel)
  ReDim Ary(1 To R.Count)
  Alphabet = "abcdefghijklmnopqrstuvwxyz"
  
  X = 0
  For Each Cel In R
    Set NewR = ThisWorkbook.Worksheets("Data").Range("B1", Cel.Offset(-1, 0))
    
    Cnt = WorksheetFunction.CountIf(NewR, Cel.Value)
    X = X + 1
    If Cnt > 0 Then
      Ary(X) = Cel.Value & Mid(Alphabet, Cnt, 1)
    Else
      Ary(X) = Cel.Value
    End If
    If X = 10 Then
      X = X
    End If
  Next Cel
  
  
  R.Value = Application.Transpose(Ary)
  
  Application.Calculation = xlCalculationAutomatic
  
End Sub
 
Upvote 0
I kind of tested this code. You may want to refine it a little. This is constantly looking above the current cell to test for duplicates. Once all the new alphabet letters have been applied it writes them back. I didn't know if you wanted the very first order number to have a letter or to be left alone.


VBA Code:
Sub Macro111()
  Dim X As Long
  Dim Cel As Range
  Dim R As Range
  Dim Alphabet As String
  Dim Cnt As Long
  Dim NewR As Range
  Dim Ary() As Variant
  Dim Sht As Worksheet
 
  Application.Calculation = xlCalculationManual
 
  Set Cel = ThisWorkbook.Worksheets("Data").Range("B100000").End(xlUp)
  Set R = ThisWorkbook.Worksheets("Data").Range("B2", Cel)
  ReDim Ary(1 To R.Count)
  Alphabet = "abcdefghijklmnopqrstuvwxyz"
 
  X = 0
  For Each Cel In R
    Set NewR = ThisWorkbook.Worksheets("Data").Range("B1", Cel.Offset(-1, 0))
   
    Cnt = WorksheetFunction.CountIf(NewR, Cel.Value)
    X = X + 1
    If Cnt > 0 Then
      Ary(X) = Cel.Value & Mid(Alphabet, Cnt, 1)
    Else
      Ary(X) = Cel.Value
    End If
    If X = 10 Then
      X = X
    End If
  Next Cel
 
 
  R.Value = Application.Transpose(Ary)
 
  Application.Calculation = xlCalculationAutomatic
 
End Sub
I kind of tested this code. You may want to refine it a little. This is constantly looking above the current cell to test for duplicates. Once all the new alphabet letters have been applied it writes them back. I didn't know if you wanted the very first order number to have a letter or to be left alone.


VBA Code:
Sub Macro111()
  Dim X As Long
  Dim Cel As Range
  Dim R As Range
  Dim Alphabet As String
  Dim Cnt As Long
  Dim NewR As Range
  Dim Ary() As Variant
  Dim Sht As Worksheet
 
  Application.Calculation = xlCalculationManual
 
  Set Cel = ThisWorkbook.Worksheets("Data").Range("B100000").End(xlUp)
  Set R = ThisWorkbook.Worksheets("Data").Range("B2", Cel)
  ReDim Ary(1 To R.Count)
  Alphabet = "abcdefghijklmnopqrstuvwxyz"
 
  X = 0
  For Each Cel In R
    Set NewR = ThisWorkbook.Worksheets("Data").Range("B1", Cel.Offset(-1, 0))
   
    Cnt = WorksheetFunction.CountIf(NewR, Cel.Value)
    X = X + 1
    If Cnt > 0 Then
      Ary(X) = Cel.Value & Mid(Alphabet, Cnt, 1)
    Else
      Ary(X) = Cel.Value
    End If
    If X = 10 Then
      X = X
    End If
  Next Cel
 
 
  R.Value = Application.Transpose(Ary)
 
  Application.Calculation = xlCalculationAutomatic
 
End Sub
Hi Jeffrey,

Thank-you for taking the time to come up with this alternative code. I'm a VBA noob so it's taken me a bit of time to understand the concept, and I'm still not too sure whether I fully understand.

However I've tried to implement your code, but it's causing issues with For Each Cell Loops further down. I tried changing the phrase from Cel to Cell, but it's creating another issue. "Run-time error '1004': Application-defined or object-defined error", and highlights this line: Set NewR = ThisWorkbook.Worksheets("Data").Range("B1", Cell.Offset(-1, 0)). Do you know what might be causing this? And is 'Cel' an issue?

Again thank-you for your help, I really appreciate it.
 
Upvote 0
Does it matter if the 1st value has an a added to it, rather than the last?
 
Upvote 0
Does it matter if the 1st value has an a added to it, rather than the last?
Hello,

No, as long as each row has a different order number it's fine. For example: 12783a, 12783b, 12783c, ... or ... ,12783c, 12783b, 12783a.
 
Upvote 0
Ok, how about
VBA Code:
Sub Yorke()
   Dim Cl As Range
   Dim Ws As Worksheet
   
   Set Ws = Sheets("Data")
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws.Range("B2", Ws.Range("B" & Rows.Count).End(xlUp))
         If Not .Exists(Cl.Value) Then
            .Add Cl.Value, 1
            Cl.Value = Cl.Value & "a"
         Else
            .Item(Cl.Value) = .Item(Cl.Value) + 1
            Cl.Value = Cl.Value & LCase(Split(Cells(1, .Item(Cl.Value)).Address, "$")(1))
         End If
      Next Cl
   End With
End Sub
 
Upvote 0
Solution
Ok, how about
VBA Code:
Sub Yorke()
   Dim Cl As Range
   Dim Ws As Worksheet
  
   Set Ws = Sheets("Data")
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws.Range("B2", Ws.Range("B" & Rows.Count).End(xlUp))
         If Not .Exists(Cl.Value) Then
            .Add Cl.Value, 1
            Cl.Value = Cl.Value & "a"
         Else
            .Item(Cl.Value) = .Item(Cl.Value) + 1
            Cl.Value = Cl.Value & LCase(Split(Cells(1, .Item(Cl.Value)).Address, "$")(1))
         End If
      Next Cl
   End With
End Sub
Perfect, thank-you!
 
Upvote 0
Glad we could help & thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,224,820
Messages
6,181,157
Members
453,021
Latest member
Justyna P

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