删除所有包含特定单词的工作表中的所有列

Question

I tried to modify the the below macro (taken elsewhere on internet) so that it applies to all the sheets within the Excel file. However it didn't work as expected. How do I make it work.

Sub Col_Delete_by_Word_2()
    Dim Found As Range, strWord As String, Counter As Long
    Dim CurrentSheet As Object
    Dim ws As Worksheet

    strWord = Application.InputBox("Enter the word to search for.", _
    "Delete the columns with this word", Type:=2)

    If strWord = "False" Or strWord = "" Then Exit Sub 'User canceled

    Set Found = Cells.Find(strWord, , , xlPart, , xlNext, False)

    For Each ws In ActiveWorkbook.Worksheets
        If Not Found Is Nothing Then
            Application.ScreenUpdating = False
            Do
                Found.EntireColumn.Delete
                Counter = Counter + 1
                Set Found = Cells.Find(strWord, , , xlPart, , xlNext, False)
            Loop Until Found Is Nothing
            Application.ScreenUpdating = True

            MsgBox Counter & " columns deleted.", vbInformation, "Process Complete"

        Else
            MsgBox "No match found for: " & strWord, vbInformation, "No Match"
        End If
    Next
End Sub

Answer 1

The problem is that you are not searching for the word in the loop. Also if you delete columns in the loop then the code will become slow. Store it in a rage variable and then delete it in one go when the search is over for that sheet.

Also when you are setting off Application events then use error handling so that if the code breaks, it can be set back to defaults. Another good thing would be to set the calculation to manual before the macro runs.

Is this what you are trying ( TRIED AND TESTED )? I have commented the code so you shouldn't have any problem understanding it. However if you do then simply post back :)

Option Explicit

Sub Col_Delete_by_Word_2()
    Dim ws As Worksheet
    Dim aCell As Range, bCell As Range, delRange As Range
    Dim strWord As Variant
    Dim appCalc As Long

    On Error GoTo Whoa

    '~~> Set the events off so that macro becomes faste
    With Application
        .ScreenUpdating = False
        appCalc = .Calculation
        .Calculation = xlCalculationManual
    End With

    '~~> Take the input from user
    strWord = Application.InputBox("Enter the word to search for.", _
    "Delete the columns with this word", Type:=2)

    '~~> Check if user pressed cancel orr is it a blank input
    If strWord = "False" Or strWord = "" Then Exit Sub

    '~~> Loop theough the worksheets
    For Each ws In ThisWorkbook.Worksheets
        With ws.Cells
            '~~> Find the search text
            Set aCell = .Find(What:=strWord, LookIn:=xlValues, _
                        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                        MatchCase:=False, SearchFormat:=False)
            '~~> If FOund
            If Not aCell Is Nothing Then
                Set bCell = aCell
                '~~> Instead of deleting the column in a loop
                '~~> We will store it in a range so that we can
                '~~> delete it later
                Set delRange = aCell

                '~~> Find Next
                Do
                    Set aCell = .FindNext(After:=aCell)

                    If Not aCell Is Nothing Then
                        If aCell.Address = bCell.Address Then Exit Do
                        Set delRange = Union(delRange, aCell)
                    Else
                        Exit Do
                    End If
                Loop
            End If

            '~~> Delete the columns in one go
            If Not delRange Is Nothing Then _
            delRange.EntireColumn.Delete Shift:=xlToLeft
        End With
    Next
LetsContinue:
    '~~> Reset events
    With Application
        .ScreenUpdating = True
        .Calculation = appCalc
    End With
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub