保留图纸的特定列 – 删除所有其他列

我的下面的代码运行良好，但不知何故需要很长时间来做这么小的操作。 而且还做得比我需要的多。 我正在寻求一些帮助来改善它。

我只需要保留表“incidents_data”的“nameA”“nameB”和“nameC”列。删除所有其他列。

我也想得到这方面的骑：“如果单元格不包含”x“，请删除。 不需要它。

Sub keep_specific_columns() Dim currentColumn As Integer Dim columnHeading As String For currentColumn = Worksheets("Incidents_data").UsedRange.Columns.Count To 1 Step -1 columnHeading = Worksheets("Incidents_data").UsedRange.Cells(1, currentColumn).Value 'CHECK WHETHER TO KEEP THE COLUMN Select Case columnHeading Case "nameA", "nameB", "nameC" 'Do nothing Case Else 'Delete if the cell doesn't contain "x" If InStr(1, _ Worksheets("Incidents_data").UsedRange.Cells(1, currentColumn).Value, _ "DLP", vbBinaryCompare) = 0 Then Worksheets("Incidents_data").Columns(currentColumn).Delete End If End Select Next End Sub 

Answer 1

 Sub keep_specific_columns() Dim currentColumn As Integer, _ columnHeading As String, _ ColzToDelete As String, _ CounT As Integer, _ Ws As Worksheet Set Ws = Worksheets("Incidents_data") With Ws For currentColumn = .UsedRange.Columns.CounT To 1 Step -1 columnHeading = .Cells(1, currentColumn).Value 'CHECK WHETHER TO KEEP THE COLUMN Select Case columnHeading Case "nameA", "nameB", "nameC" 'Do nothing Case Else 'Delete store the columns to delete them at the end ColzToDelete = ColzToDelete & "," & _ Col_Letter(currentColumn) & ":" & Col_Letter(currentColumn) CounT = CounT + 1 End Select If CounT <> 10 Then Else 'Delete when you have 10 columns .Range(Right(ColzToDelete, Len(ColzToDelete) - 1)).Delete Shift:=xlToLeft ColzToDelete = vbNullString CounT = 0 End If Next currentColumn If ColzToDelete <> vbNullString Then .Range(Right(ColzToDelete, Len(ColzToDelete) - 1)).Delete Shift:=xlToLeft End With End Sub Function Col_Letter(lngCol As Long) As String Col_Letter = Split(Cells(1, lngCol).Address(True, False), "$")(0) End Function