Populate unique values into a VBA array from Excel

Question

Can anyone give me VBA code that will take a range  row or column  from an Excel sheet and populate a list array with the unique values   i e     table table chair table stool stool stool chair   when the macro runs would create an array some thing like    fur 0  table fur 1  chair fur 2  stool

User · Answer

Combining the Dictionary approach from Tim with the variant array from Jean_Francois below.

The array you want is in objDict.keys

enter image description here

Sub A_Unique_B()
Dim X
Dim objDict As Object
Dim lngRow As Long

Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range([a1], Cells(Rows.Count, "A").End(xlUp)))

For lngRow = 1 To UBound(X, 1)
    objDict(X(lngRow)) = 1
Next
Range("B1:B" & objDict.Count) = Application.Transpose(objDict.keys)
End Sub

User · Answer

The old school method was my favourite option  Thank you  And it was indeed fast   But I didn t use redim   Here though is my real world example where I accumulate values for each unique  key  found in a column and move it into a array  say for an employee and values are hours worked per day   Then I put each key with its final values into a totals area on the active sheet  I ve commented extensively for anyone who wants painful detail on what is happening here   Limited error checking is done by this code     Sub GetActualTotals       GetActualTotals Macro     This macro accumulates values for each unique employee from the active   spreadsheet      History   October 2016 - Version 1     Invocation   I created a button labeled  Get Totals  on the Active Sheet that invokes   this macro    Dim ResourceName As String Dim TotalHours As Double Dim TotalPercent As Double Dim IsUnique As Boolean Dim FirstRow  LastRow  LastColumn  LastResource  nUnique As Long Dim CurResource  CurrentRow  i  j As Integer Dim Resource 1000  2  As Variant Dim Rng  r As Range     INITIALIZATIONS     These are index numbers for the Resource array   Const RName   0 Const TotHours   1 Const TotPercent   2     Set the maximum number of resources we ll   process    Const ResourceLimit   1000     We are counting on there being no unintended data   in the spreadsheet      It won t matter if the cells are empty though  It just   may take longer to run the macro    But if there is data where this macro does not expect it    assume unpredictable results      There are some hardcoded values used    This macro just happens to expect the names to be in Column C  or 3       Get the last row in the spreadsheet    LastRow   Cells Find What                         After  Range  C1                      LookAt  xlPart                    LookIn  xlFormulas                    SearchOrder  xlByRows                    SearchDirection  xlPrevious                    MatchCase  False  Row      Furthermore  this macro banks on the first actual name to be in C6     so if the last row is row 65  the range we ll work with     will evaluate to  C6 C65    FirstRow   6 Rng    C   amp  FirstRow  amp    C   amp  LastRow Set r   Range Rng      Initialize the resource array to be empty  even though we don t really   need to but I m old school       For CurResource   0 To ResourceLimit     Resource CurResource  RName           Resource CurResource  TotHours    0     Resource CurResource  TotPercent    0 Next CurResource     Start the resource counter at 0   The counter will represent the number of   unique entries      nUnique   0     LET S GO     Loop from the first relative row and the last relative row   to process all the cells in the spreadsheet we are interested in   For i   1 To LastRow - FirstRow     Loop here for all unique entries  For any   new unique entry  that array element will be   initialized in the second if statement        IsUnique   True     For j   1 To nUnique     If the current row element has a resource name and is already   in the resource array  then accumulate the totals for that   Resource Name  We then have to set IsUnique to false and   exit the for loop to make sure we don t populate   a new array element in the next if statement            If r Cells i  1  Value   Resource j  RName  Then             IsUnique   False             Resource j  TotHours    Resource j  TotHours                  r Cells i  4  Value             Resource j  TotPercent    Resource j  TotPercent                  r Cells i 5  Value             Exit For         End If      Next j     If the resource name is unique then copy the initial   values we find into the next resource array element    I ignore any null cells     If the cell has a blank you might   want to add a Trim to the cell     Not much error checking for    the numerical values either        If   IsUnique  And  r Cells i  1  Value  lt  gt       Then         nUnique   nUnique   1         Resource nUnique  RName    r Cells i  1  Value         Resource nUnique  TotHours    Resource nUnique  TotHours               r Cells i  4  Value         Resource nUnique  TotPercent    Resource nUnique  TotPercent              r Cells i  5  Value     End If                   Next i     Done processing all rows      For readability  Set the last resource counter to the last value of   nUnique    Set the current row to the first relative row in the range  r the range     LastResource   nUnique CurrentRow   1     Populate the destination cells with the accumulated values for   each unique resource name    For CurResource   1 To LastResource     r Cells CurrentRow  7  Value   Resource CurResource  RName      r Cells CurrentRow  8  Value   Resource CurResource  TotHours      r Cells CurrentRow  9  Value   Resource CurResource  TotPercent      CurrentRow   CurrentRow   1 Next CurResource  End Sub

User · Answer

The VBA script below looks for all unique values from cell B5 all the way down to the very last cell in column B     B 1048576  Once it is found  they are stored in the array  objDict    Private Const SHT MASTER      MASTER    Private Const SHT INST INDEX      InstrumentIndex     Sub UniqueList       Dim Xyber     Dim objDict As Object     Dim lngRow As Long      Sheets SHT MASTER  Activate     Xyber   Application Transpose Sheets SHT MASTER  Range  b5   Cells Rows count     B     End xlUp        Sheets SHT INST INDEX  Activate     Set objDict   CreateObject    Scripting Dictionary         For lngRow   1 To UBound Xyber  1      If Len Xyber lngRow    gt  0 Then objDict Xyber lngRow     1     Next     Sheets SHT INST INDEX  Range    B1 B     amp  objDict count    Application Transpose objDict keys  End Sub   I have tested and documented with some screenshots of the this solution  Here is the link where you can find it      http   xybernetics com techtalk excelvba-getarrayofuniquevaluesfromspecificcolumn

User · Answer

This is the old-school way of doing it    It will execute faster than looping through cells  e g  For Each cell In Selection  and will be reliable no matter what  as long you have a rectangular selection  i e  not Ctrl-selecting a bunch of random cells     Sub FindUnique        Dim varIn As Variant     Dim varUnique As Variant     Dim iInCol As Long     Dim iInRow As Long     Dim iUnique As Long     Dim nUnique As Long     Dim isUnique As Boolean      varIn   Selection     ReDim varUnique 1 To UBound varIn  1    UBound varIn  2        nUnique   0     For iInRow   LBound varIn  1  To UBound varIn  1          For iInCol   LBound varIn  2  To UBound varIn  2               isUnique   True             For iUnique   1 To nUnique                 If varIn iInRow  iInCol    varUnique iUnique  Then                     isUnique   False                     Exit For                 End If             Next iUnique              If isUnique   True Then                 nUnique   nUnique   1                 varUnique nUnique    varIn iInRow  iInCol              End If          Next iInCol     Next iInRow         varUnique now contains only the unique values           Trim off the empty elements      ReDim Preserve varUnique 1 To nUnique  End Sub

User · Answer

one more way      Sub get unique   Dim unique string As String     lr   Sheets  data   Cells Sheets  data   Rows Count  1  End xlUp  Row     Set range1   Sheets  data   Range  A2 A   amp  lr      For Each cel In range1        If Not InStr output  cel Value   gt  0 Then            unique string   unique string  amp  cel Value  amp             End If     Next End Sub

User · Answer

Sub GetUniqueAndCount        Dim d As Object  c As Range  k  tmp As String      Set d   CreateObject  scripting dictionary       For Each c In Selection         tmp   Trim c Value          If Len tmp   gt  0 Then d tmp    d tmp    1     Next c      For Each k In d keys         Debug Print k  d k      Next k  End Sub

User · Answer

OK I did it finally   Sub CountUniqueRecords   Dim Array   as variant  UniqueArray   as variant  UniqueNo as Integer        Dim i as integer  j as integer  k as integer  Redim UnquiArray 1   k  Upbound array   For i   1 To k For j   1 To UniqueNo   1   If Array i    UniqueArray j  Then GoTo Nx Next j   UniqueNo   UniqueNo   1   ReDim Preserve UniqueArray UniqueNo   1    UniqueArray UniqueNo    Array i  Nx  Next i  MsgBox UniqueNo  End Sub

User · Answer

If you don t mind using the Variant data type  then you can use the in-built worksheet function Unique as shown  sub unique results to array       dim rng data as Range     set rng data   activesheet range  quot A1 A10 quot    enter the range of data here      dim my arr   as Variant     my arr   WorksheetFunction Unique rng data           first val    my arr 1 1      second val   my arr 2 1      third val   my arr 3 1     etc         end sub

User · Answer

Profiting from the MS Excel 365 function UNIQUE    In order to enrich the valid solutions above   Sub ExampleCall   Dim rng As Range  Set rng   Sheet1 Range  A2 A11        lt  lt  change to your sheet s Code Name  Dim a  a   rng a   getUniques a  arrInfo a End Sub   Function getUniques a  Optional ZeroBased As Boolean   True  Dim tmp  tmp   Application Transpose WorksheetFunction Unique a   If ZeroBased Then ReDim Preserve tmp 0 To UBound tmp  - 1  getUniques   tmp End Function

User · Answer

This VBA function returns an array of distinct values when passed either a range or a 2D array source  It defaults to processing the first column of the source  but you can optionally choose another column   I wrote a LinkedIn article about it   Function DistinctVals a  Optional col   1      Dim i amp   v  v   a     With CreateObject  Scripting Dictionary           For i   1 To UBound v    Item v i  col     1  Next         DistinctVals   Application Transpose  Keys      End With End Function

User · Answer

In this situation I always use code like this  just make sure delimeter you ve chosen is not a part of search range     Dim tmp As String Dim arr   As String  If Not Selection Is Nothing Then    For Each cell In Selection       If  cell  lt  gt      And  InStr tmp  cell    0  Then         tmp   tmp  amp  cell  amp            End If    Next cell End If  If Len tmp   gt  0 Then tmp   Left tmp  Len tmp  - 1   arr   Split tmp

[excel] Populate unique values into a VBA array from Excel

Examples related to excel

Examples related to vba