VBA: Delete Entire Columns based on Header value in Excel

[unknownymous]

Hi Gurus,

Good day!

I found below code in deleting specific column. However, I want to apply it for all tab sheets. Suppose I have 15 sheets.

= = =
Sub DeleteSpecifcColumn()

Dim xFNum, xFFNum, xCount As Integer
Dim xStr As String
Dim xArrName As Variant
Dim MR, xRg As Range

On Error Resume Next

Set MR = Range("A1:BZ1")

xArrName = Array("old", "new", "get") 'enclose each column name with double quotes and separate them by comma
xCount = MR.Count
xStr = xArrName(xFNum)

For xFFNum = xCount To 1 Step -1
Set xRg = Cells(1, xFFNum)
For xFNum = 0 To UBound(xArrName)

xStr = xArrName(xFNum)
If xRg.Value = xStr Then xRg.EntireColumn.Delete

Next xFNum

Next

End Sub

'Source: How to delete entire columns based on header value in Excel?

= = =
For the array "new" and "get", I noticed that whenever I paste it in from my sheet to VBA there's a double quote already. Adding an extra double quote is not working like:
xArrName = Array("old", ""new"", ""get"")

Any thoughts on how to update the the VBA codes above?

Thanks in advance!

 

[kevin9999]

Try the following on a copy of your file:

Option Explicit
Option Compare Text
Sub DelCols()
    Dim ws As Worksheet, DelMe As Range, LCol As Long, i As Long, j As Long, HdrArr
    HdrArr = Array("old", "new", "get")
    
    For Each ws In Worksheets
        With ws
            LCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
            For i = 1 To LCol
                For j = LBound(HdrArr) To UBound(HdrArr)
                    If .Cells(1, i) = HdrArr(j) Then
                        If DelMe Is Nothing Then
                            Set DelMe = .Columns(i)
                        Else
                           Set DelMe = Union(DelMe, .Columns(i))
                        End If
                    End If
                Next j
            Next i
        End With
        If Not DelMe Is Nothing Then DelMe.Delete
        Set DelMe = Nothing
    Next ws
End Sub

 

[unknownymous]

Try the following on a copy of your file:

Option Explicit
Option Compare Text
Sub DelCols()
    Dim ws As Worksheet, DelMe As Range, LCol As Long, i As Long, j As Long, HdrArr
    HdrArr = Array("old", "new", "get")
   
    For Each ws In Worksheets
        With ws
            LCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
            For i = 1 To LCol
                For j = LBound(HdrArr) To UBound(HdrArr)
                    If .Cells(1, i) = HdrArr(j) Then
                        If DelMe Is Nothing Then
                            Set DelMe = .Columns(i)
                        Else
                           Set DelMe = Union(DelMe, .Columns(i))
                        End If
                    End If
                Next j
            Next i
        End With
        If Not DelMe Is Nothing Then DelMe.Delete
        Set DelMe = Nothing
    Next ws
End Sub

This is working however, I am having a problem as the "New Data" and "Get Data" columns were not deleted probably because of the header format. Whenever I use the find option, it looks like this "Get Data" (with double quote).

 

[kevin9999]

Try this alternative

Option Explicit
Option Compare Text
Sub DelCols()
    Dim ws As Worksheet, DelMe As Range, LCol As Long, i As Long
    
    For Each ws In Worksheets
        With ws
            LCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
            For i = 1 To LCol
                
                    If .Cells(1, i) Like "*old*" Or _
                        .Cells(1, i) Like "*new*" Or _
                        .Cells(1, i) Like "*get*" Then
                        If DelMe Is Nothing Then
                            Set DelMe = .Columns(i)
                        Else
                           Set DelMe = Union(DelMe, .Columns(i))
                        End If
                    End If
            Next i
        End With
        If Not DelMe Is Nothing Then DelMe.Delete
        Set DelMe = Nothing
    Next ws
End Sub

 

[kevin9999]

Did the amended code in post #4 make a difference?