Extract Unique Values Across Multiple Sheets

[tommychowdah]

Hi Everyone!

I searched through other forums for VBA code that would accomplish this, but was unable to find anything that worked.

Essentially, I have 5 sheets (year 1, year 2... etc). In column A of each sheet, I have account numbers. i would like to extra all unique accounts numbers and paste them to a different sheet. Does anyone have any code that would help accomplish this?

Many thanks,
Tommy

 

[rlv01]

'' 'Example of how to use scripting dictionary to list unique values
''' Assumes data is in column A of "Sheet1", "Sheet2", "Sheet3", "Sheet4", & "Sheet5"
''' Results are written to "Sheet6"
'
Sub GetUnique()
    Dim Rng As Range, R As Range
    Dim SD As Object
    Dim KeyStr As String, RefStr As String
    Dim WB As Workbook
    Dim WS As Worksheet
    Dim I As Long

    Set WB = ActiveWorkbook
    Set WS = ActiveSheet

    Set SD = CreateObject("Scripting.dictionary")
    RefStr = ""    'Value stored in dictionary

    For Each WS In WB.Worksheets
        Select Case WS.Name
        Case "Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5"
            Set Rng = WS.Range("A1:A" & WS.Range("A" & WS.Rows.count).End(xlUp).Row)
            For Each R In Rng
                KeyStr = R.Value    'Search Key stored in dictionary
                If Not SD.Exists(KeyStr) Then    'Unique key value, not already in the dictionary
                    SD.Add KeyStr, RefStr
                End If
            Next R
        End Select
    Next WS

    Set WS = WB.Worksheets("Sheet6")
    WS.Range("A1").EntireColumn.ClearContents

    With WS.Range("A1")
        For I = 0 To SD.count - 1
            .Offset(I).Value = SD.keys()(I)
        Next I
    End With
End Sub

 

[tommychowdah]

Thank you! I will give this a shot and let you know if I have any issues.