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

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

1 个答案: