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

[Yorke]

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!

 

[Jeffrey Mahoney]

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.

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

 

[Yorke]

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.

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.

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.

 

[Fluff]

Does it matter if the 1st value has an a added to it, rather than the last?

 

[Yorke]

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.

 

[Fluff]

Ok, how about

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

 

[Yorke]

Ok, how about

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!

 

[Fluff]

Glad we could help & thanks for the feedback.