如何使Excel VBA宏删除带有许多不同字符串作为标题的列？

Question

So I'm importing a large spreadsheet with anywhere from 20 to 40 headers at the top and I'd like to automatically (and quickly) delete all the columns with specific headers. I have a current code that works, but it loops through all the columns multiple times, each time looking for a different string. I would like it to loop through once and delete any column that has any of the strings to delete.

Here's a fraction of my code to explain a little better:

Sub SetUpICTRP()

‘MsgBox “Excel will refresh when macro is complete”
Application.ScreenUpdating = False

Dim c As Range
Dim SrchRng As Range
Dim lastColumn As Long

lastColumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Set SrchRng = ActiveSheet.Range("A1", Cells(1, lastColumn))   

Do
    Set c = SrchRng.Find("column", LookIn:=xlValues)
    If Not c Is Nothing Then c.EntireColumn.Delete
Loop While Not c Is Nothing
Do
    Set c = SrchRng.Find("Erroneous", LookIn:=xlValues)
    If Not c Is Nothing Then c.EntireColumn.Delete
Loop While Not c Is Nothing
Do
    Set c = SrchRng.Find("Unnecessary", LookIn:=xlValues)
    If Not c Is Nothing Then c.EntireColumn.Delete
Loop While Not c Is Nothing
Do
    Set c = SrchRng.Find("Not_", LookIn:=xlValues)
    If Not c Is Nothing Then c.EntireColumn.Delete
Loop While Not c Is Nothing
Application.ScreenUpdating = True
End Sub

So currently it will delete all the columns with headers that contain the phrase "column," "Erroneous," "Unnecessary", and "Not_". What I really need is for it to be able to find and delete columns like "column218", "columnadfe", "column099", "Not_needed", without running through a separate loop multiple times. I think the solution lies somehow in creating an array of strings and then looping through each string for each column, but I'm rather new to VBA and can't seem to make that work. Any help would be great!

Answer 1

You could loop through and find the words and use the Union() method to collate your headers into a single Range object, then use the .EntireColumn method to delete columns related to the non-contiguous cells.

---

Sub SO()

Dim findValue As Variant, findRange As Excel.Range, deleteRange As Excel.Range
Dim findAddress As String

For Each findValue In Array("column", "Erroneous", "Unnecessary", "Not_", _
    "Other1", "Other2", "Other3", "etc...")

    Set findRange = Rows(1).EntireRow.Find(what:=findValue, LookIn:=xlValues, lookat:=xlPart)

    If Not findRange Is Nothing Then
        findAddress = findRange.Address
        Do
            If Not deleteRange Is Nothing Then
                Set deleteRange = Union(deleteRange, findRange)
            Else
                Set deleteRange = findRange
            End If

            Set findRange = Rows(1).EntireRow.FindNext(findRange)
        Loop Until findRange Is Nothing Or findRange.Address = findAddress

    Set findRange = Nothing
    End If

Next findValue

If deleteRange Is Nothing Then
    MsgBox "No columns were found for deletion!"
Else
    deleteRange.EntireColumn.Delete
End If

End Sub

or following your original setup you could use something like:

Sub SO()

Dim c As Range, findValue As Variant

For Each findValue In Array("column", "Erroneous", "Unnecessary", "Not_", _
    "Other1", "Other2", "Other3", "etc...")
    Do
        Set c = Rows(1).EntireRow.Find(findValue, LookIn:=xlValues)
        If Not c Is Nothing Then c.EntireColumn.Delete
    Loop While Not c Is Nothing

Next findValue

End Sub