VBA to create list from range based on unique first five characters of the string

[sureng19]

Some data strings in column A has common first five characters. I want to extract those first five characters and create a list in column B where there will not be any duplicates.
Please see the attached image. I was trying to manipulate code that used a "Scripting Dictionary" and trim the string to left 5 characters but was not going anywhere. Thanks in advance.

 

[zero269]

Some data strings in column A has common first five characters. I want to extract those first five characters and create a list in column B where there will not be any duplicates.
Please see the attached image. I was trying to manipulate code that used a "Scripting Dictionary" and trim the string to left 5 characters but was not going anywhere. Thanks in advance. View attachment 106567

This will return your unique first five characters, but will be a spilled result:

VBA Testing.xlsm
	A	B
1	List	Unique
2	21117 Mangos 001	21117
3	21117 Mangos 002	21045
4	21117 Mangos 003	21046
5	21117 Bananas 001	21047
6	21117 Bananas 002	42987
7	21045 Apples 001	42980
8	21046 Apples 001
9	21047 Green Apples 001
10	21047 Red Apples 001
11	42987 Mangos 001
12	42980 Mangos 001
UniqueRight

Cell Formulas
Range	Formula
B2:B7	B2	=UNIQUE(LEFT(A2:A12,5))
Dynamic array formulas.

 

[mse330]

VBA option ...

Sub test()

With CreateObject("scripting.dictionary")
    For x = 2 To Range("A" & Rows.Count).End(3).Row
        If Not .exists(Left(Cells(x, 1), 5)) Then .Add Left(Cells(x, 1), 5), Nothing
    Next
    Cells(2, 2).Resize(.Count) = Application.Transpose(.keys)
End With

End Sub

 

[Peter_SSs]

I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

 

[sureng19]

VBA option ...

Sub test()

With CreateObject("scripting.dictionary")
    For x = 2 To Range("A" & Rows.Count).End(3).Row
        If Not .exists(Left(Cells(x, 1), 5)) Then .Add Left(Cells(x, 1), 5), Nothing
    Next
    Cells(2, 2).Resize(.Count) = Application.Transpose(.keys)
End With

End Sub

Peter, Thank you very much. Works exactly the way I want. Script turned out to be lot simpler than I thought and simple enough for me to learn a tad more about VBA. Thanks again!!

 

[Peter_SSs]

Works exactly the way I want. Script turned out to be lot simpler than I thought and simple enough for me to learn a tad more about VBA. Thanks again!!

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.

Peter, Thank you very much.

Secondly, I did not provide the answer so I think that you are thanking the wrong person.

Thirdly, what I did ask you was to put your Excel version in your account details so helpers can provide the best help to you in future & you haven't done that yet.

 

[sureng19]

VBA option ...

Sub test()

With CreateObject("scripting.dictionary")
    For x = 2 To Range("A" & Rows.Count).End(3).Row
        If Not .exists(Left(Cells(x, 1), 5)) Then .Add Left(Cells(x, 1), 5), Nothing
    Next
    Cells(2, 2).Resize(.Count) = Application.Transpose(.keys)
End With

End Sub

mse330, Thanks for the solution. By mistake I thanked the wrong person and only today I realized that. Nevertheless, thank you.

 

[Peter_SSs]

.. what I did ask you was to put your Excel version in your account details ..

Thanks for doing that.

BTW, you could use the formula concept suggested by @zero269 to produce a vba solution that doesn't require looping through each cell in the range.

Sub test2()
  With Range("A2", Range("A" & Rows.Count).End(xlUp))
    .Cells(1, 2).Formula2 = "=unique(left(" & .Address & ",5))"
    .Cells(1, 2).SpillingToRange.Value = .Cells(1, 2).SpillingToRange.Value
  End With
End Sub