VBA删除除所有工作表中指定的列以外的所有Excel列-VBADeleteallExcelcolumnsexceptthosenamedinallworksheets

I am looking for a VBA script that will delete all columns in all worksheets of a an excel workbook except those named:

我正在寻找一个VBA脚本，它将删除excel工作簿的所有工作表中的所有列，除了那些名为：

Date
Name
Amount Owing
Balance

the following code is working but it only apply in the active worksheet :

以下代码正在运行，但它仅适用于活动工作表：

Sub DeleteSelectedColumns()
Dim currentColumn As Integer
Dim columnHeading As String

For currentColumn = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
    columnHeading = ActiveSheet.UsedRange.Cells(1, currentColumn).Value

'Check whether to preserve the column
    Select Case columnHeading
    'Insert name of columns to preserve
        Case "Date", "Name", "Amount Owing", "Balance"
            'Do nothing
        Case Else
            'Delete the column
            ActiveSheet.Columns(currentColumn).Delete
        End Select
    Next
End Sub

Can someone help me modify this code to apply on all worksheets of a workbook ?

有人可以帮我修改此代码以应用于工作簿的所有工作表吗？

1 个解决方案

Sub DeleteSelectedColumns()

    Dim ws As Worksheet
    Dim rDel As Range
    Dim HeaderCell As Range
    Dim sKeepHeaders As String
    Dim sDelimiter as String

    sDelmiter = ":"
    sKeepHeaders = Join(Array("Date", "Name", "Amount Owing", "Balance"), sDelimiter)

    For Each ws In ActiveWorkbook.Sheets
        Set rDel = Nothing
        For Each HeaderCell In ws.Range("A1", ws.Cells(1, ws.Columns.Count).End(xlToLeft)).Cells
            If InStr(1, sDelimiter & sKeepHeaders & sDelimiter, sDelimiter & HeaderCell.Value & sDelimiter, vbTextCompare) = 0 Then
                If Not rDel Is Nothing Then Set rDel = Union(rDel, HeaderCell) Else Set rDel = HeaderCell
            End If
        Next HeaderCell
        If Not rDel Is Nothing Then rDel.EntireColumn.Delete
    Next ws

End Sub