VBA loop through column and store values in an array-CodePudding

I have my column B, starting from cell 2 (because of the header) containing codes of type String. I would like to get a list of these codes. However, these codes are repeated a number of times. So I would like to loop through my column B and add to my array of codes whenever a new one is encountered, if that makes sense.

Here is my code. How can this be done ? Thanks in advance.

Sub List()

Dim listCodes() As String

With Worksheets("My sheet)

    nbr_lines = .Rows.Count
    Dim i As Long
   
    val_old = .Cells(2, 2).Value

    listCodes(1) = val_old 

    For i = 2 To nbr_lines
        val_new = .Cells(i   1, 2).Value
        
        While val_old = val_new
            val_old = val_new
            
        Wend
        
        listCodes(i) = val_new
        val_old = val_new
    Next i
        

End With
End Sub

CodePudding user response：

As mentioned in my comment, I'd suggest a dictionary. Drop the entire column into an array for speedy processing first, then throw it all in the dictionary:

Sub List()

Dim listCodes() As Variant
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim nbr_lines As Long

With Worksheets("My sheet")
    
    'Get last used line and throw values in array;
    nbr_lines = .Cells(.Rows.Count, 2).End(xlUp).Row
    listCodes = .Range("B2:B" & nbr_lines).Value
    
    'Loop array instead of cells for speed. Add all unique items into dictionary;
    For Each el In listCodes
        dict(el) = ""
    Next
    
    'Add the content of the dictionary to the sheet;
    .Range("C2").Resize(dict.Count).Value = Application.Transpose(dict.Keys)

End With

End Sub

Note: This can also be achieved outside of VBA through easy formulae like the UNIQUE() function.

CodePudding user response：

You can use dictionary approach. Below sub will copy only unique items to column D. Modify codes as your need.

Public Sub CopyUniqueOnly()
Dim i As Long

    Dim currCell As Range, dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    With ThisWorkbook.Worksheets("Sheet1")
        For Each currCell In .Range("B2", .Cells(.Rows.Count, 2).End(xlUp))
            If Not dict.exists(currCell.Value) And Not IsEmpty(currCell) Then
                dict.Add currCell.Value, currCell.Value
            End If
        Next currCell
    End With
    
    Range("D2").Resize(dict.Count) = Application.Transpose(dict.keys)
    
End Sub