删除所有其他列

此代码是一个macros,它在不同的工作表中search一些值并删除它们的列。 但是,如果我想要删除所有其他列,并保留它们,我该怎么办?

换句话说,我想让macros观做相反的事情?

码:

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 

我会采取的做法是循环通过列,在模式数组中依次search,找不到的时候删除。

这是你的Sub的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