Удалить все столбцы на всех листах, содержащих определенное слово

Question

Я попытался изменить макрос ниже (взятый в другом месте в Интернете), чтобы он применим ко всем листам в файле Excel. Однако это не сработало, как ожидалось. Как заставить его работать.

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

Проблема в том, что вы не ищете слово в цикле. Также, если вы удалите столбцы в цикле, тогда код станет медленным. Храните его в переменной ярости, а затем удаляйте его за один раз, когда поиск завершен для этого листа.

Также, когда вы устанавливаете Application событий, используйте обработку ошибок, чтобы при разрыве кода его можно было вернуть к значениям по умолчанию. Еще одна хорошая вещь - установить вычисление вручную до запуска макроса.

Это то, что вы пытаетесь (TRIED AND TESTED)? Я прокомментировал код, поэтому у вас не должно возникнуть проблем с его пониманием. Однако если вы это сделаете, просто отправьте обратно :)

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