удалить все остальные столбцы

Question

Этот код является макросом, который ищет некоторые значения на разных листах и ​​удаляет их столбцы. Но что мне делать, если я хочу удалить все остальные столбцы вместо и оставить их для поиска?

другими словами, я хочу, чтобы макрос делал наоборот?

код:

    Sub Level()
Dim calcmode As Long
Dim ViewMode As Long
Dim myStrings As Variant
Dim FoundCell As Range
Dim I As Long
Dim wsSkador As Worksheet
Dim ws As Worksheet
With Application
    calcmode = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
End With
    myStrings = Array("Apple", "Banan")
    For Each ws In ActiveWorkbook.Worksheets
With ws.Range("A6:EE6")

        For I = LBound(myStrings) To UBound(myStrings)
            Do
               Set FoundCell = .Find(What:=myStrings(I), _
                                           After:=.Cells(.Cells.Count), _
                                           LookIn:=xlFormulas, _
                                           LookAt:=xlPart, _
                                           SearchOrder:=xlByRows, _
                                           SearchDirection:=xlNext, _
                                           MatchCase:=False)

                If FoundCell Is Nothing Then
                    Exit Do
                Else
                    FoundCell.EntireColumn.Delete
                End If
            Loop
        Next I
End With
    Next ws
    End Sub

Answer 1

Подход, который я выбрал бы, состоит в том, чтобы циклически проходить по столбцам, искать каждый по очереди в массиве шаблонов и удалять, когда не найден.

Вот отозванная версия вашего Sub:

Sub Level()
    Dim calcmode As Long
    Dim ViewMode As Long
    Dim myStrings As Variant
    Dim FoundCell As Range
    Dim I As Long
    Dim wsSkador As Worksheet
    Dim ws As Worksheet
    Dim cl As Range
    Dim Found As Boolean
    Dim DeleteRange As Range

    On Error GoTo EH

    With Application
        calcmode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    myStrings = Array("a", "s")
    For Each ws In ActiveWorkbook.Worksheets
        Set DeleteRange = Nothing
        For Each cl In ws.[A6:EE6]
            If cl <> "" Then
                Found = False
                For I = LBound(myStrings) To UBound(myStrings)
                    If LCase$(cl.Formula) Like LCase$("*" & myStrings(I) & "*") Then
                        Found = True
                        Exit For
                    End If
                Next I
                If Not Found Then
                    If DeleteRange Is Nothing Then
                        Set DeleteRange = cl
                    Else
                        Set DeleteRange = Union(DeleteRange, cl)
                    End If
                End If
            End If
        Next cl
        If Not DeleteRange Is Nothing Then
            DeleteRange.EntireColumn.Delete
        End If
    Next ws
    With Application
        .Calculation = calcmode
        .ScreenUpdating = True
        .EnableEvents = True
    End With
Exit Sub
EH:
    Debug.Assert
    'Resume  ' Uncomment this to retry the offending code
End Sub