他のすべての列を削除

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

アプローチが見つからない場合deleteing、パターンアレイに順番にそれぞれを検索、列をループです。

はここにあなたのサブのrewoked verionです：

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