刪除所有表中包含特定單詞的所有列

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