Excel VBA Create a list and add only unique terms

Question

I am trying to pull strings from column A and move them to column B only if they don't already exist in column B. To do this, I wanted to make a list and scan all of column A with it, however, I'm not sure how to do that in VBA. In python I recall using something along the lines of

[If (x) not in (List)]

but that same approach isnt working for me in Excel.

Currently, I have the following

Sub GatherAll()

GL = List()
rwcnt = WorksheetFunction.CountA(Range("A:A"))
lastc = Cells(1, Columns.Count).End(xlToLeft).Column
Dim i As Long

For i = 2 To rwcnt
    Cells(i, 1).Value = n

and I want to say something like

if n not in GL, GL.append(n)
continue

End Sub

If anyone could help me out, I would really appreciate it.

Would copy-pasting all of Column A, then using Excel's Remove Duplicates feature work just as well? — user4691433
– user4691433, Commented Jul 28, 2015 at 19:14
It does not, column B is empty and honestly the list of unique strings can be placed anywhere, I just chose B cause it wasn't A. — Scott T
– Scott T, Commented Jul 28, 2015 at 19:14
MatthewD's question is important. Do you want to create a new list in column B every time you launch the macro, or add to the existing list? (Which may have values not present in A at all). — David G
– David G, Commented Jul 28, 2015 at 19:20
every time I launch the macro I would like a new list in the column — Scott T
– Scott T, Commented Jul 28, 2015 at 19:27

basodre · Accepted Answer · 2015-07-28 19:14:27Z

3

Try adapting the following code to your exact needs and see if it helps. If you need help, let us know.

Sub MoveUniqueEntries()
    Dim oDict As Object
    Dim rToMove As Range
    Dim rDest As Range
    Dim rLoop As Range

    Set oDict = CreateObject("Scripting.Dictionary")
    Set rToMove = Intersect(Sheet1.Range("A1").CurrentRegion, Sheet1.Columns(1))
    Set rDest = Sheet1.Range("B1")

    For Each rLoop In rToMove
        If oDict.exists(rLoop.Value) Then
            'Do nothing
        Else
            oDict.Add rLoop.Value, 0
            rDest.Value = rLoop.Value
            Set rDest = rDest.Offset(1)
        End If
    Next rLoop
End Sub

answered Jul 28, 2015 at 19:14

basodre

5,7901 gold badge18 silver badges25 bronze badges

Sign up to request clarification or add additional context in comments.

5 Comments

David G Over a year ago

If you choose this method, note that you must first enable reference to the Microsoft Scipting Runtime by going (in the VBE) in Tools > References > Check "Microsoft Scipting Runtime". This makes it possible for the file to use dictionnaries (whether it is being used on your computer, or a collegue's computer, doesn't matter).

basodre Over a year ago

@DavidGM It is my understanding that a reference to Microsoft Scripting Runtime is not necessary since we've used late binding (CreateObject). If we choose to use early binding (Dim oDict as New Scripting.Dictionary), then we'd need to create the reference

David G Over a year ago

Maybe you are right, I never did it your way. I didn't think it was unnecessary when late binding! @ScottT Did you have to do what I wrote?

basodre Over a year ago

@DavidGM Thanks for mentioning it though. Reference issues potentially throw errors that are always annoying to diagnose. I checked my References, and I don't have the Scripting Runtime selected, yet I use Dictionaries all the time.

Scott T Over a year ago

I already had Microsoft Scripting Runtime activated, so I don't know if it was necessary or not, sorry!

MatthewD · Accepted Answer · 2015-07-28 19:21:14Z

1

In your VBA IDE you will have to add a reference. On the tools pulldown menu select references. Then select "Microsoft ActiveX Data Objects 2.8 Library".

Dim rs As New ADODB.Recordset
Dim ws As Excel.Worksheet
Dim lRow As Long

    Set ws = Application.ActiveSheet
    'Add fields to your recordset for storing data.  You can store sums here.
    With rs
        .Fields.Append "Row", adInteger
        .Fields.Append "Value", adInteger
        .Open
    End With

    lRow = 1

    'Loop through and record what is in the first column
    Do While lRow <= ws.UsedRange.Rows.count

        rs.AddNew
        rs.Fields("Row").Value = lRow
        rs.Fields("Value").Value = ws.Range("A" & lRow).Value
        rs.Update

        lRow = lRow + 1
        ws.Range("A" & lRow).Activate
    Loop

    'Now go through and list out the unique values in columnB.
    lRow = 1
    rs.Sort = "value"
    Do While lRow <= ws.UsedRange.Rows.count
        if rs.Fields("value").Value <> strLast then

            ws.Range("B" & lRow).Value = rs.Fields("value").Value

            lRow = lRow + 1
        End if
        strLast = rs.Fields("value").Value
    Loop

answered Jul 28, 2015 at 19:21

MatthewD

6,8215 gold badges24 silver badges44 bronze badges

2 Comments

Scott T Over a year ago

Thanks for the aid again, I'll definitely look back at this in the future :D

MatthewD Over a year ago

Sure thing. Reading data into a recordset is a very flexible way to do things. You can filter and sort the recordset as well as access it for any need.

Tim Williams · Accepted Answer · 2015-07-28 21:04:00Z

1

Cross-platform version (but will be slow for large numbers of values):

Sub UniquesTester()

    Dim v, u(), i As Long, n As Long
    n = 0
    v = Range(Range("A1"), Cells(Rows.Count, 1).End(xlUp)).Value
    ReDim u(1 To UBound(v, 1))
    For i = 1 To UBound(v, 1)
        If IsError(Application.Match(v(i, 1), u, 0)) Then
            n = n + 1
            u(n) = v(i, 1)
        End If
    Next i
    ReDim Preserve u(1 To n)

    Range("c1").Resize(n, 1).Value = Application.Transpose(u)

End Sub

answered Jul 28, 2015 at 21:04

Tim Williams

169k8 gold badges104 silver badges143 bronze badges

Collectives™ on Stack Overflow

Excel VBA Create a list and add only unique terms

3 Answers 3

5 Comments

2 Comments

Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

3 Answers 3

5 Comments

2 Comments

Comments

Your Answer

Sign up or log in

Post as a guest

Related