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

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