Count unique values and return results in another column

Question

I have values in column B (green, blue, white....) and I want to count them and the result must appear in column A in the following format (green01, green02, green03...., blue01, blue02, blue03, blue04...., white01, white 02...).

The result must look like in this photo

I have searched the net for a macro, but I didn't find one to fit my needs.

THX

Must the font of each color reflect the name, like in your picture, or that coloring is only for making the picture more elocvent...? Are the colors in B;B sorted somehow? — FaneDuru, May 11 '20 at 12:48
@FaneDuru The colour does not matter. I put it there only to show the differences. — Alin, May 11 '20 at 13:08
Test my code, please. It colors also the font. But you can comment/delete the last line of the loop... — FaneDuru, May 11 '20 at 13:10

score 0 · Accepted Answer · answered May 11 '20 at 12:44

0

No VBA needed, in A1:

=B1&TEXT(COUNTIF(B$1:B1,B1),"00")

answered May 11 '20 at 12:44

JvdV

70,606
8
39
70

score 0 · Answer 2 · answered May 11 '20 at 13:09

Try the next code, please:

Sub testCountSortColors()
 Dim sh As Worksheet, lastRow As Long, i As Long, c As Long
  Set sh = ActiveSheet
  lastRow = sh.Range("B" & Rows.count).End(xlUp).Row
  sh.Range("B1:B" & lastRow).Sort key1:=sh.Range("B1"), order1:=xlAscending, Header:=xlYes

  For i = 2 To lastRow
    If sh.Range("B" & i).value <> sh.Range("B" & i - 1).value Then
        c = 1
    Else
        c = c + 1
    End If
    sh.Range("A" & i).value = sh.Range("B" & i).value & Format(c, "00")
    sh.Range("A" & i).Font.Color = sh.Range("B" & i).Font.Color
  Next
End Sub

I thought you maybe have column headers...

score 0 · Answer 3 · answered May 11 '20 at 14:04

A Unique Count

Adjust the values in the constants section.

Option Explicit

Sub countUnique()

    Const SourceColumn As Variant = 2   ' e.g. 2 or "B"
    Const TargetColumn As Variant = 1   ' e.g. 1 or "A"
    Const FirstRow As Long = 1

    Dim rng As Range
    Dim dict As Object
    Dim Key As Variant
    Dim Source As Variant, Target As Variant
    Dim i As Long, UB As Long
    Dim CurrString As String

    Set rng = Columns(SourceColumn).Find(What:="*", _
      LookIn:=xlFormulas, SearchDirection:=xlPrevious)
    If rng Is Nothing Then GoTo exitProcedure
    If rng.Row < FirstRow Then GoTo exitProcedure
    Source = Range(Cells(FirstRow, SourceColumn), rng)
    Set rng = Nothing

    UB = UBound(Source)
    Set dict = CreateObject("Scripting.Dictionary")
    For i = 1 To UB
        If Source(i, 1) <> "" Then
            dict(Source(i, 1)) = dict(Source(i, 1)) + 1
        End If
    Next i

    ReDim Target(1 To UB, 1 To 1)
    For i = UB To 1 Step -1
        CurrString = Source(i, 1)
        If CurrString <> "" Then
            Target(i, 1) = CurrString & Format(dict(CurrString), "00")
            dict(CurrString) = dict(CurrString) - 1
        End If
    Next i

    With Cells(FirstRow, TargetColumn)
        .Resize(Rows.Count - FirstRow + 1).ClearContents
        .Resize(UB) = Target
    End With

    MsgBox "Operation finished successfully."

exitProcedure:

End Sub

Count unique values and return results in another column

3 Answers3

A Unique Count