VBA保留某些列并删除所有其他列

正如话题所说，我有一个vba代码来完成这项工作：删除表单“事件”的所有列，只保留名称为“状态”，“名称”和“年龄”的列

但由于某种原因，在几千行之后，它不能正常工作，并且删除正在保存的那些列的数据/单元格，而且工作起来也相当慢。

还有其他方法可以做到吗？ 更有效吗？ 至less不要删除必须保留在表单中的任何列的单元格。

在此先感谢（代码如下）。

Sub Cleanup_report2() Dim currentColumn As Integer Dim columnHeading As String For currentColumn = Worksheets("Incidents").UsedRange.Columns.CounT To 1 Step -1 columnHeading = Worksheets("Incidents).UsedRange.Cells(1, currentColumn).Value 'CHECK WHETHER TO KEEP THE COLUMN Select Case columnHeading Case "Status", "Name", "Age" 'Do nothing Case Else If InStr(1, _ Worksheets("Incidents").UsedRange.Cells(1, currentColumn).Value, _ "DLP", vbBinaryCompare) = 0 Then Worksheets("Incidents").Columns(currentColumn).Delete End If End Select Next End Sub 

Answer 1

只做一个删除操作应该更快一些：

 Sub Cleanup_report2() Dim currentColumn As Integer Dim columnHeading As String Dim rDelete As Excel.Range With Worksheets("Incidents_data") For currentColumn = .UsedRange.Columns.Count To 1 Step -1 columnHeading = .UsedRange.Cells(1, currentColumn).Value 'CHECK WHETHER TO KEEP THE COLUMN Select Case columnHeading Case "Status", "Name", "Age" 'Do nothing Case Else If InStr(1, columnHeading, "DLP", vbBinaryCompare) = 0 Then If rDelete Is Nothing Then Set rDelete = .UsedRange.Cells(1, currentColumn) Else Set rDelete = Union(rDelete, .UsedRange.Cells(1, currentColumn)) End If End If End Select Next End With If Not rDelete Is Nothing Then rDelete.EntireColumn.Delete End Sub 

Answer 2

这是我的激情…希望这有助于…

 Sub removeColumns() Dim rng As Range 'store the range you want to delete Dim c 'total count of columns Dim i 'an index Dim j 'another index Dim headName As String 'The text on the header Dim Status As String 'This vars is just to get the code cleaner Dim Name As String Dim Age As String Dim sht As Worksheet Status = "Status" Name = "Name" Age = "Age" Set sht = Sheets("Incidents") sht.Activate 'all the work in the sheet "Incidents" c = Range("A1").End(xlToRight).Column 'From A1 to the left at the end, and then store the number 'of the column, that is, the last column j = 0 'initialize the var For i = 1 To c 'all the numbers (heres is the columns) from 1 to c headName = Cells(1, i).Value If (headName <> Status) And (headName <> Name) And (headName <> Age) Then 'if the header of the column is differente of any of the options j = j + 1 ' ini the counter If j = 1 Then 'if is the first then Set rng = Columns(i) Else Set rng = Union(rng, Columns(i)) End If End If Next i rng.Delete 'then brutally erased from leaf End Sub