What's the best way to copy the unique items in one column of one listobject table to a column in another listobject table?

Question

I'm building an excel timesheet to track the temp employees time and OT per job worked. The way things are set up now works okay but I'd like to make it more efficient.

I need to find the unique values from the "Job #" column in the listObject table "MAIN" and copy them to the "Job #" column in the listObject table "SUMMARY".

I'm using excel 365. I've tried using dictionary objects and can't get my head wrapped around it at the moment. I found this bit of code but haven't been able to make it work for me.

Dim arr
Dim x As Long
Dim rng As Range

arr = mainTable.ListColumns("JOB NAME").DataBodyRange


With CreateObject("Scripting.Dictionary")
    For x = LBound(arr) To UBound(arr)
        If Not IsMissing(arr(x, 1)) Then .Item(arr(x, 1)) = 1
    Next
    arr = .Keys
End With

Set tbl = Worksheets("Summary by Job").ListObjects("SUMMARY")
Set rng = Range("SUMMARY[#All]").Resize(UBound(arr, 1), tbl.Range.Columns.Count)
tbl.HeaderRowRange.Resize(UBound(arr, 1) + 1).Offset(1).Value = Application.Transpose(arr)

Once I got this adjusted for spreadsheet it copied the data across all of the columns. I also would like a way to return the number of unique entries.

See this: https://stackoverflow.com/questions/3017852/vba-get-unique-values-from-array — AcsErno, Jul 20 '19 at 17:35

Ahmed AU · Answer 1 · 2019-07-21T13:46:33.820

may try something like this (please modify sheet name table names to your requirement, i tried to keep it similar for test purpose).in VBA project added reference to "Microsoft scripting runtime"

Sub test()
Dim Arr As Variant, Rslt As Variant, X As Long
Dim Rng As Range, Dict As Dictionary
Dim Tbl As ListObject, MainTable As ListObject
Dim Ws As Worksheet, RsltCnt As Long, ColCnt As Long
Set Ws = ThisWorkbook.Worksheets("Summary by Job")
Set MainTable = Ws.ListObjects("MAIN")
Set Tbl = Ws.ListObjects("SUMMARY")
ColCnt = MainTable.HeaderRowRange.Columns.Count

Arr = MainTable.DataBodyRange
ReDim Rslt(1 To ColCnt, 1 To 1)

Set Dict = CreateObject("Scripting.Dictionary")
RsltCnt = 1

    For X = 1 To UBound(Arr, 1)
        If Dict.Exists(Arr(X, 1)) = False Then
        Dict.Add Arr(X, 1), 1
        ReDim Preserve Rslt(1 To ColCnt, 1 To RsltCnt)
            For Y = 1 To ColCnt
            Rslt(Y, RsltCnt) = Arr(X, Y)
            Next
        RsltCnt = RsltCnt + 1
        Else
        Dict(Arr(X, 1)) = Dict(Arr(X, 1)) + 1  ' Dict will hold the count of unique key value 
        End If
    Next

'this would copy the unique array at the end of table SUMMARY
Tbl.DataBodyRange(Tbl.DataBodyRange.Rows.Count, 1).Offset(1, 0).Resize(UBound(Rslt, 2), UBound(Rslt, 1)).Value = Application.Transpose(Rslt)
End Sub

Thanks! I'll give this a shot first thing tomorrow morning! – Thomas Savino Jul 21 '19 at 15:20 — Thomas Savino, Jul 21 '19 at 15:20

What's the best way to copy the unique items in one column of one listobject table to a column in another listobject table?

1 Answers1