Search code examples
excelvbaexcel-tableslistobject

VBA Selecting Multiple Noncontiguous Table Columns by Name


This following code works, but it needs to be simplified so that the table columns are deleted with one line of code if possible. The columns are noncontiguous and are downloaded straight from a website that supplies the data, so I can only work with what I'm given each time I download the data.

Sub dataSort()
    
    ActiveSheet.ListObjects.Add(xlSrcRange, _
                                Range([A1].End(xlDown), [A1].End(xlToRight)), _
                                , xlYes).Name = "dataSort"
    
    Range("dataSort[Vortex ID]").Delete
    Range("dataSort[Lead Status]").Delete
    Range("dataSort[Listing Status]").Delete
    Range("dataSort[Address]").Delete
    Range("dataSort[Mailing City]").Delete
    Range("dataSort[Mailing State]").Delete
    Range("dataSort[Mailing Zip]").Delete
    Range("dataSort[List Price]").Delete
    Range("dataSort[Lead Date]").Delete
    Range("dataSort[Status Date]").Delete
    Range("dataSort[Type]").Delete
    Range("dataSort[Lot Size]").Delete
    Range("dataSort[Phone Counter]").Delete
    Range("dataSort[Email Counter]").Delete
    Range("dataSort[Mail Counter]").Delete
    Range("dataSort[House Number]").Delete
    Range("dataSort[Tax ID]").Delete
    
End Sub

Solution

  • Delete Excel Table Columns By Title

    Sub CleanData()
        
        Const TABLE_NAME As String = "DataSort"
        Dim ColumnTitles() As Variant: ColumnTitles = Array( _
            "Vortex ID", "Lead Status", "Listing Status", "Address", _
            "Mailing City", "Mailing State", "Mailing Zip", "List Price", _
            "Lead Date", "Status Date", "Type", "Lot Size", _
            "Phone Counter", "Email Counter", "Mail Counter", "House Number", _
            "Tax ID")
        
        Dim ws As Worksheet: Set ws = ActiveSheet
        Dim lo As ListObject: Set lo = ws.ListObjects.Add(xlSrcRange, _
            ws.Range("A1").CurrentRegion, , xlYes)
        lo.Name = TABLE_NAME
         
        Dim urg As Range, crg As Range, n As Long
        
        For n = LBound(ColumnTitles) To UBound(ColumnTitles)
            On Error Resume Next ' prevent error if column doesn't exist
                Set crg = lo.ListColumns(ColumnTitles(n)).Range
            On Error GoTo 0
            If Not crg Is Nothing Then ' column exists
                If urg Is Nothing Then Set urg = crg Else Set urg = Union(urg, crg)
                Set crg = Nothing ' reset for the next iteration
            End If
        Next n
    
        If Not urg Is Nothing Then urg.Delete Shift:=xlShiftToLeft
    
    End Sub