CODEWITHSUNDEEP
arraysvbaloopsconditional-statementsselection
Fabian Stolz
Fabian Stolz

Reputation: 2095

VBA: Selecting unique values in a column, adding them to an array and writing the array in a table

I got a table with various data. In one column we find some sort of project number which occurs from time to time again. I want to create of list with each project number in it.

So I thought about creating an array and adding the number to it if it is not yet present in the existing array.

Finally the array should be shown in a table

This is with what I have come up so far:

Sub ChoseNumbers()
' Chosing the Numbers in the AreaDim Arr() As Integer
Dim i As Integer
Dim area As Range

Set area = Columns("N").cells

i = 0
For Each cell In area
    If IsEmpty(cell) Then
        Exit For
    ElseIf i = 0 Then
        ReDim Preserve Arr(i)
        Arr(UBound(Arr)) = cell.Value
        i = i + 1
    ElseIf IsInArray(cell.Value, Arr) = False Then
        ReDim Preserve Arr(i)
        Arr(UBound(Arr)) = cell
        i = i + 1
    End If
Next cell


'Giving the selection out again

For i = 1 To (UBound(Arr))

cells(i, 1).Value = Arr(i)

Next i

End Sub

Thanks for your advice!

Upvotes: 1

Views: 15439

Answers (3)

Brian
Brian

Reputation: 2108

To add you could also put

Activeworkbook.Worksheets("WorksheetName").Range("YourRange") =     
Application.Transpose(ObjDic.keys)

Upvotes: 0

B Hart
B Hart

Reputation: 1118

If you're going to be looping through a range of cells and are just looking for a simple and effective way to assign unique values to a single dimensional array, I would look at the Dictionary Object: http://www.w3schools.com/asp/asp_ref_dictionary.asp

Set objDic = CreateObject("Scripting.Dictionary")
For Each Cell In Area
    If Not objDic.Exists(Cell.Value) Then
        objDic.Add Cell.Value, Cell.Address
    End If
Next

I = 1
For Each Value In objDic.Keys
    Cells(I,1).Value = Value
    I = I + 1
Next

Upvotes: 6

Skytunnel
Skytunnel

Reputation: 1083

I've rewritten your code to make use of the RemoveDuplicates feature

Option Explicit
Sub ChoseNumbers()

Dim WS As Worksheet
Dim area As Range
Dim arr As Variant
Dim i As Long

Const SheetName As String = "Sheet1"
Const FromColumnIndex As Long = 14 'Column N
Const ToColumnIndex As Long = 1 'Column A

Set WS = ThisWorkbook.Worksheets(SheetName)
Set area = WS.Cells(1, FromColumnIndex).Resize( _
    WS.Cells(1, FromColumnIndex).End(xlDown).Row)

'Make Copy
area.Copy
WS.Cells(1, ToColumnIndex).PasteSpecial xlPasteValues
Application.CutCopyMode = False

'Remove Duplicates (from copy)
area.Offset(, ToColumnIndex - FromColumnIndex).RemoveDuplicates Array(1)

'Move to Array
arr = WS.Cells(1, ToColumnIndex).Resize( _
    WS.Cells(1, ToColumnIndex).End(xlDown).Row)

'Print Results
For i = LBound(arr, 1) To UBound(arr, 1)
    Debug.Print arr(i, 1)
Next

End Sub

Also, a useful tip... you can add an excel range directly into a vba array as done above arr = ... this outputs a two dimensional array (e.g rows + columns)

Also, made use of the .End(xlDown) to find the last populate cell in a column

Upvotes: 0

Related Questions