Delete Excel table column based on heading name in a list

Question

I have a spreadsheet of data that has the best part of 120 columns of data in it of which I don't all of them, so for file size I delete the ones I do not need. I figured this could be automated and have put together a VB function based on a script I found online which checks column headings against a list of values and if that value is in the list, it deletes the column.

As the column count in the spreadsheet changes due to updates, rather than fix the column reference in the code, I input a start and end column into two cells which the VB code reads but for some reason, I get an error when I select the exact column count. If I choose a smaller column count (ie: table is columns D:K and I choose D:F) the code runs fine and the columns are deleted. Can anyone maybe explain where the code is falling over as I am a newbie to VB.

Many thanks.

Here is the code I'm using and if I can figure out how to upload the example file I will do that as well:

Sub DeleteSpecifcColumn()

    Dim rngFound As Range, rngToDelete As Range
    Dim strFirstAddress, fstCol, LstCol As String
    Dim varList As Variant
    Dim lngCounter As Long

    fstCol = ActiveSheet.Range("B2").Value
    LstCol = ActiveSheet.Range("B3").Value

    Application.ScreenUpdating = False

    'varList = Range("Sheet1!B3:B8").Value
    varList = ActiveSheet.ListObjects("Delete").ListColumns(1).DataBodyRange

    For lngCounter = LBound(varList) To UBound(varList)

        'Fixed column range
        'With ActiveSheet.Range("E:F")

        'Using table headings
        'With ActiveSheet.ListObjects("Content").HeaderRowRange

        'Cell values on sheet to build column range and then search against list
        With ActiveSheet.Range(vbDblQuote & fstCol & ":" & LstCol & vbDblQuote)
        Set rngFound = .Find( _
                                What:=varList(lngCounter, 1), _
                                Lookat:=xlWhole, _
                                SearchOrder:=xlByColumns, _
                                SearchDirection:=xlNext, _
                                MatchCase:=True _
                                    )

            If Not rngFound Is Nothing Then
                If rngToDelete Is Nothing Then
                    Set rngToDelete = rngFound
                Else
                    Set rngToDelete = Application.Union(rngToDelete, rngFound)
                End If

                strFirstAddress = rngFound.Address
                Set rngFound = .FindNext(After:=rngFound)

                Do Until rngFound.Address = strFirstAddress
                    Set rngToDelete = Application.Union(rngToDelete, rngFound)
                    Set rngFound = .FindNext(After:=rngFound)
                Loop
            End If
        End With
    Next lngCounter

    If Not rngToDelete Is Nothing Then rngToDelete.EntireColumn.Delete

    Application.ScreenUpdating = True

End Sub

So the columns to delete are not part of the table? The table simply lists the columns to delete? — QHarr, Apr 18 '18 at 10:24
Is the first column always in the same place, but the last column can change? — Darren Bartrup-Cook, Apr 18 '18 at 10:34
Do the column names repeat? You're using `FindNext` which indicates that each column heading could appear multiple times and you want to remove them all? — Darren Bartrup-Cook, Apr 18 '18 at 10:49
Hi guys, thank you for all the responses. The columns to delete are in a second table and the first column will always be in the same place but the last column can change. The data I use only contains unique headings, there are no duplicate headings. Thanks. — Marc, Apr 18 '18 at 20:06

PoorlyWrittenCode · Accepted Answer · 2018-04-18T11:42:36.237

0

Would something like this work? Assuming all of your headings are in the first row.

Sub DeleteHeadings()
  Dim headingsToDelete() As Variant: headingsToDelete = Array("a", "b", "c")
  Dim deletedOffset As Integer: deletedOffset = 0

  For Column = 1 To ActiveSheet.UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column
    If (IsInArray(ActiveSheet.Cells(1, Column).Value, headingsToDelete)) Then
      ActiveSheet.Columns(Column - deletedOffset).Delete
      deletedOffset = deletedOffset + 1
    End If
  Next
End Sub

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
  IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function

IsInArray function: How to find if an array contains a string

last ued column: http://www.globaliconnect.com/excel/index.php?Itemid=475&catid=79&id=86:last-used-row-last-used-column-vba&option=com_content&view=article

edited Apr 18 '18 at 11:42

answered Apr 18 '18 at 10:47

PoorlyWrittenCode

1,003
1
7
10

Hi, thanks for the above. I would work on a small list of headings but unfortunately my table contains approx 120 columns of which two thirds are not required. Will definitely look to use that though. Thanks again. – Marc Apr 18 '18 at 20:07
Ah, missed the part about the ListObject. Can't say I've used those. But a quick search shows you could just convert that to an array. https://www.thespreadsheetguru.com/blog/2014/6/20/the-vba-guide-to-listobject-excel-tables under Reading Table Data Into An Array Variable So maybe something like: `headingsToDelete = Application.Transpose(ActiveSheet.ListObjects("Delete").ListColumns(1).DataBodyRange)` – PoorlyWrittenCode Apr 18 '18 at 21:53

score 0 · Answer 2 · answered Apr 18 '18 at 11:02

If the headings only appear once you can use:

Public Sub DeleteSpecificColumn()

    Dim rngFound As Range, rngToDelete As Range
    Dim rDeleteValue As Range
    Dim fstCol As Long, lstCol As Long

    With ThisWorkbook.Worksheets("Sheet1") 'We're working with the workbook containing the code in "Sheet1".
        For Each rDeleteValue In .ListObjects("Delete").ListColumns(1).DataBodyRange
            With .Range("D1", .Cells(1, .Columns.Count).End(xlToLeft)) 'References D1 to last cell in row 1 containing data.
                Set rngFound = .Find( _
                    What:=CStr(rDeleteValue), _
                    Lookat:=xlWhole, SearchOrder:=xlByColumns, _
                    SearchDirection:=xlNext, _
                    MatchCase:=True)
                If Not rngFound Is Nothing Then
                    If rngToDelete Is Nothing Then
                        Set rngToDelete = rngFound
                    Else
                        Set rngToDelete = Application.Union(rngToDelete, rngFound)
                    End If
                End If
                Set rngFound = Nothing
            End With
        Next rDeleteValue
    End With

    If Not rngToDelete Is Nothing Then rngToDelete.EntireColumn.Delete

End Sub

If the headings appear multiple times you can use:

Public Sub DeleteSpecificColumn()

    Dim rngFound As Range, rngToDelete As Range
    Dim rDeleteValue As Range
    Dim fstCol As Long, lstCol As Long
    Dim sFirstAddress As String

    With ThisWorkbook.Worksheets("Sheet1") 'We're working with the workbook containing the code in "Sheet1".
        For Each rDeleteValue In .ListObjects("Delete").ListColumns(1).DataBodyRange
            With .Range("D1", .Cells(1, .Columns.Count).End(xlToLeft)) 'References D1 to last cell in row 1 containing data.
                Set rngFound = .Find( _
                    What:=CStr(rDeleteValue), _
                    Lookat:=xlWhole, SearchOrder:=xlByColumns, _
                    SearchDirection:=xlNext, _
                    MatchCase:=True)

                If Not rngFound Is Nothing Then
                    sFirstAddress = rngFound.Address

                    Do
                        If rngToDelete Is Nothing Then
                            Set rngToDelete = rngFound
                        Else
                            Set rngToDelete = Application.Union(rngToDelete, rngFound)
                        End If

                        Set rngFound = .FindNext(rngFound)
                    Loop While rngFound.Address <> sFirstAddress
                End If
                Set rngFound = Nothing
            End With
        Next rDeleteValue
    End With

    If Not rngToDelete Is Nothing Then rngToDelete.EntireColumn.Delete

End Sub

Both sets of code start at D1 and finish at the last column containing data (or formula). The code .Cells(1, .Columns.Count).End(xlToLeft) is the same as going to cell XFD1 and pressing Ctrl+Left.

No problem. Feel free to tick as the accepted answer if it is. — Darren Bartrup-Cook, Apr 19 '18 at 07:52

Delete Excel table column based on heading name in a list

2 Answers2