Using Excel VBA, how can i extract data from a named table and manipulate the data without changing the data in the original table?

Question

In Excel VBA, I am trying to extract a unique list of values from a column in an named table. I want to store the unique list of values in a variable that I can then use for further processing. I am using the following code to do this:

    Dim SomeData As Range
     
    Set SomeData = ThisWorkbook.Sheets("Tab") _
    
        .ListObjects("TableName").ListColumns("ColumnName").DataBodyRange  
    
    SomeData.RemoveDuplicates Columns:=1, Header:=xlNo

However, this code removes duplicates from the underlying table - which I don't want to do.

Is there a simple way to extract the data from the table and store it in a variable that I can manipulate without changing the underlying data in the named table?

Answer 1

Retrieve Distinct Rows

Criteria (Single) Column

Sub RetrieveDistinctColumn()

    ' Reference the workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the source objects and return the criteria column values
    ' in a 2D one-based (single-column) array.
    Dim sws As Worksheet: Set sws = wb.Sheets("Tab")
    Dim slo As ListObject: Set slo = sws.ListObjects("TableName")
    Dim slc As ListColumn: Set slc = slo.ListColumns("ColumnName")
    ' Assumes more than one cell.
    Dim sData() As Variant: sData = slc.DataBodyRange.Value
    
    ' Retrieve the source number of rows.
    Dim sRowsCount As Long: sRowsCount = UBound(sData, 1)
    
    ' Create and reference a dictionary object.
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' A=a
    
    ' Declare addtional variables.
    Dim Value As Variant, rStr As String, sRow As Long
    
    ' Loop through the rows of the source array and return each valid (first)
    ' dictinct string representation of the criteria column in the keys,
    ' and the corresponding row index in the items (values) of the dictionary.
    For sRow = 1 To sRowsCount
        Value = sData(sRow, 1)
        If Not IsError(Value) Then ' no error
            rStr = CStr(Value)
            If Len(rStr) > 0 Then ' no blank
                If Not dict.Exists(rStr) Then dict(rStr) = sRow
            End If
        End If
    Next sRow
    
    ' Define the (resulting) destination array.
    Dim dRowsCount As Long: dRowsCount = dict.Count
    If dRowsCount = 0 Then Exit Sub ' only errors and blanks
    Dim dData() As Variant: ReDim dData(1 To dRowsCount, 1 To 1)
    
    ' Declare addtional variables.
    Dim dRow As Long
    
    ' Loop through the keys of the dictionary and use the corresponding
    ' items, the source row indices, to write the required (dictinct) rows
    ' from the source to the destination array.
    For Each Value In dict.Items
        sRow = Value ' current source row
        dRow = dRow + 1 ' current destination row
        dData(dRow, 1) = sData(sRow, 1)
    Next Value
    
    ' Do something with the destination array ('dData')...

End Sub

All Columns

Sub RetrieveDistinctRows()

    ' Reference the workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the source objects and return the source table values
    ' in a 2D one-based array.
    Dim sws As Worksheet: Set sws = wb.Sheets("Tab")
    Dim slo As ListObject: Set slo = sws.ListObjects("TableName")
    Dim slc As ListColumn: Set slc = slo.ListColumns("ColumnName")
    ' Assumes more than one cell.
    Dim sData() As Variant: sData = slo.DataBodyRange.Value
    
    ' Retrieve the source criteria column and the number of rows and columns.
    Dim CriteriaColumn As Long: CriteriaColumn = slc.Index
    Dim sRowsCount As Long: sRowsCount = UBound(sData, 1)
    Dim ColumnsCount As Long: ColumnsCount = UBound(sData, 2)
    
    ' Create and reference a dictionary object.
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' A=a
    
    ' Declare addtional variables.
    Dim Value As Variant, rStr As String, sRow As Long
    
    ' Loop through the rows of the source array and return each valid (first)
    ' distinct string representation of the criteria column in the keys,
    ' and the corresponding row index in the items (values) of the dictionary.
    For sRow = 1 To sRowsCount
        Value = sData(sRow, CriteriaColumn)
        If Not IsError(Value) Then ' no error
            rStr = CStr(Value)
            If Len(rStr) > 0 Then ' no blank
                If Not dict.Exists(rStr) Then dict(rStr) = sRow
            End If
        End If
    Next sRow
    
    ' Define the (resulting) destination array.
    Dim dRowsCount As Long: dRowsCount = dict.Count
    If dRowsCount = 0 Then Exit Sub ' only errors and blanks
    Dim dData() As Variant: ReDim dData(1 To dRowsCount, 1 To ColumnsCount)
    
    ' Declare addtional variables.
    Dim dRow As Long, Col As Long
    
    ' Loop through the keys of the dictionary and use the corresponding
    ' items, the source row indices, to write the required (dictinct) rows
    ' from the source to the destination array.
    For Each Value In dict.Items
        sRow = Value ' current source row
        dRow = dRow + 1 ' current destination row
        For Col = 1 To ColumnsCount
            dData(dRow, Col) = sData(sRow, Col)
        Next Col
    Next Value
    
    ' Do something with the destination array ('dData')...

End Sub

Answer 2

Add the values to a collection using the cell value as the key - you can't have duplicate keys in a collection.

Public Sub Test()

    On Error GoTo Err_Handler

    Dim MyCol As Collection
    Set MyCol = New Collection
    
    Dim Cell As Range
    For Each Cell In ThisWorkbook.Worksheets("Tab").ListObjects("TableName").ListColumns("ColumnName").DataBodyRange
        MyCol.Add Cell.Value2, Cell
    Next Cell
    
    Debug.Assert False
    
    On Error GoTo 0
    
Exit Sub
Err_Handler:
    Select Case Err.Number
        Case 457 'This key is already associated with an element of this collection
            Resume Next
        Case Else
            MsgBox Err.Number & vbCr & Err.Description, vbOKOnly + vbCritical, "Module1.Test()"
    End Select

End Sub  

Or

You can use Application.Worksheetfunction.Unique:

Public Sub Test()

    Dim MyVar As Variant
    MyVar = Application.WorksheetFunction.Unique(ThisWorkbook.Worksheets("Tab").ListObjects("TableName").ListColumns("ColumnName").DataBodyRange)
    
End Sub  

Answer 3

I'd suggest to use a dictionary if you want to store only unique values

Option Explicit

Sub returnNoDuplicates()
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    Dim lo As ListObject
    Dim ws As Worksheet
    

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set lo = ws.ListObjects("tblData")
    
    Dim vDat As Variant
    vDat = lo.ListColumns("B1").DataBodyRange

    Dim i As Long
    
    For i = LBound(vDat) To UBound(vDat)
        ' Add the value to the dictionary
        ' If the value already exists,
        ' it will not be added again (ensuring uniqueness)
        dict(vDat(i, 1)) = vDat(i, 1)
    Next i
    
    vDat = dict.Keys
End Sub

The array vdat, like the dictionary dict, will contain the result. It's up to you which data structure you want to use.

Answer 4

A workaround to save the datarange before removing duplicates, and later restore it.

Sub rest()

Dim lo As ListObject
Set lo = Range("A1").ListObject
backup = lo.DataBodyRange  'save original table
lo.DataBodyRange.RemoveDuplicates 1, xlNo
filtered = lo.DataBodyRange 'this is the filtered result
lo.DataBodyRange.Resize(UBound(backup)) = backup  'restore original data

End Sub