Code to pick up unique references in a cell from a different worksheet

[fusion007]

Hi...I would like a list of values in a column in worksheet A to be created from unique values in column B from worksheet B. Values in this can be the same for many rows so I only want unique values. In worksheet I want a drop down list that a user picks.
Can anyone help with this please? Thanks

[Leith Ross]

Hello fusion007,

This macro will return an array (single column) of unique values that are sorted.

'Written: July 07, 2011
'Author:  Leith Ross
'Summary: Finds uniques values in a single column range and returns them
'         in a sorted 2-D (n x 1) array.

Function GetSortedUniques(ByRef Rng As Range, Optional Descending As Boolean)

  Dim Cell As Range
  Dim Dict As Object
  Dim Key As Variant
  
  Dim arr As Variant
  Dim B As Long
  Dim I As Long
  Dim J As Long
  Dim N As Long
  Dim Temp As Variant
  
    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.CompareMode = vbTextCompare
    
    For Each Cell In Rng.Columns(1).Cells
      Key = Trim(Cell)
      If Key <> "" Then
        If Not Dict.Exists(Key) Then Dict.Add Key, Cell.Value
      End If
    Next Cell
    
      arr = Dict.Items
      
      B = LBound(arr)
      N = UBound(arr)
    
      For I = B To N
        For J = B To N - 1
          If Descending Xor (arr(I) < arr(J)) Then
             Temp = arr(J)
             arr(J) = arr(I)
             arr(I) = Temp
          End If
        Next J
      Next I
    
    GetSortedUniques = WorksheetFunction.Transpose(arr)
    
End Function

Macro Example
Change the worksheet names and ranges to what you are using. For the destination range (DstRng), you only need to specify the first cell of the list.

Sub Macro1()

  Dim arr As Variant
  Dim DstRng AS Range
  Dim SrcRng AS Range

    Set SrcRng = Worksheets("SheetB").Range("B:B")
    Set DstRng = Worksheets("SheetA").Range("A1")

    arr = GetSortedUniques(SrcRng)
    DstRng,Resize(UBound(arr), 1) = arr

End Sub