This script prompts the user to select a range, then puts all the unique values from that range into a single column list on a new worksheet
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Public Sub WriteUniquesToNewSheet() | |
Dim wksUniques As Worksheet | |
Dim rngUniques As Range, rngTarget As Range | |
Dim strPrompt As String | |
Dim varUniques As Variant | |
Dim lngIdx As Long | |
Dim colUniques As Collection | |
Set colUniques = New Collection | |
'Prompt the user to select a range to unique-ify | |
strPrompt = "Select the Range from which you'd like to extract uniques" | |
On Error Resume Next | |
Set rngTarget = Application.InputBox(strPrompt, "Get Range", Type:=8) | |
On Error GoTo 0 | |
If rngTarget Is Nothing Then Exit Sub '<~ in case the user clicks Cancel | |
'Collect the uniques using the function we just wrote | |
Set colUniques = CollectUniques(rngTarget) | |
'Load a Variant array with the uniques | |
'(in preparation for writing them to a new sheet) | |
ReDim varUniques(colUniques.Count, 1) | |
For lngIdx = 1 To colUniques.Count | |
varUniques(lngIdx - 1, 0) = CStr(colUniques(lngIdx)) | |
Next lngIdx | |
'Create a new worksheet (where we will store our uniques) | |
Set wksUniques = ThisWorkbook.Worksheets.Add | |
Set rngUniques = wksUniques.Range("A1:A" & colUniques.Count) | |
rngUniques = varUniques | |
'Let the user know we're done! | |
MsgBox "Finished!" | |
End Sub |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment