从多个工作表中删除多个列

Question

我正在尝试从多个工作表中删除多个列，同时保留在列表中找到的那些。

例如我有sheet1、sheet2、sheet3、...、sheet7。 从这些表格中，我有一些特定的列要保留。

来自sheet1 我想保留s.no、cust.name、product、date 之类的列，应该从sheet2 中删除相同的列 我想保留prod.disc,address、pin 剩下的所有应该删除，就像我有剩余的工作表一样，我想保留特定的列，所有应该被删除。 我正在尝试使用数组但无法开始如何做。我有基本的语法。

Sub sbVBS_To_Delete_Specific_Multiple_Columns()
Sheets("Sheet1").Range("A:A,C:C,H:H,K:O,Q:U").EntireColumn.Delete
End Sub`[code]

但这对我不起作用，因为将来可能会在其中添加一些列，我希望列应该通过名称识别要保留和丢弃的列。

Answer 1

好的，这是基本代码。指定要在主过程中删除的工作表和列。设置子过程中查找字幕的行。

Sub DeleteColumns()
    ' 17 Mar 2017

    Dim ClmCaption As Variant
    Dim Ws As Worksheet
    Dim i As Integer

    Set Ws = ActiveSheet
    ' better to specify the sheet by name, like Set Ws = ThisWorkbook.Worksheets("My Excel")

    Application.ScreenUpdating = False      ' freeze screen (speeds up execution)
    ClmCaption = Array("One", "two", "three", "four", "five")
    ' specify all the columns you want to delete by caption , not case sensitive

    For i = 0 To UBound(ClmCaption)         ' loop through all the captions
        DelColumn Ws, CStr(ClmCaption(i))   ' call the sub for each caption
    Next i
    Application.ScreenUpdating = True       ' update screen
End Sub

Private Sub DelColumn(Ws As Worksheet, Cap As String)
    ' 17 Mar 2017

    Dim CapRow As Long
    Dim Fnd As Range

    CapRow = 3                              ' this is the row where the captions are
    Set Fnd = Ws.Rows(CapRow).Find(Cap)     ' find the caption
    If Fnd Is Nothing Then
        MsgBox "The caption """ & Cap & """ doesn't exist." & vbCr & _
               "The column wasn't deleted.", _
               vbInformation, "Invalid parameter"
    Else
        Ws.Columns(Fnd.Column).EntireColumn.Delete Shift:=xlToLeft
    End If
End Sub

您可以按原样运行代码，但您会收到很多错误消息，因为指定的标题不存在。

Answer 2

以下使用 Scripting Dictionary 对象，该对象维护要作为字典 keys 处理的工作表列表，并带有列标题标签数组以保留为关联的 items .

Option Explicit

Sub delColumnsNotInDictionary()
    Dim d As Long, ky As Variant, dict As Object
    Dim c As Long, lc As Long

    Set dict = CreateObject("Scripting.Dictionary")
    dict.comparemode = vbTextCompare

    dict.Item("Sheet1") = Array("s.no", "cust.name", "product", "date")
    dict.Item("Sheet2") = Array("prod.disc", "address", "pin")
    dict.Item("Sheet50") = Array("foo", "bar")

    With ThisWorkbook
        For Each ky In dict.keys
            With Worksheets(ky)
                lc = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlPart, _
                                 SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, _
                                 MatchCase:=False, SearchFormat:=False).Column
                For c = lc To 1 Step -1
                    'filter array method of 'not found in array'
                    'WARNING! CASE SENSITIVE SEARCH  - foo <> FOO
                    If UBound(Filter(dict.Item(ky), .Cells(1, c).Value2)) = -1 Then
                        '.Cells(1, c).EntireColumn.Delete
                    Else
                        Debug.Print .Cells(1, c).Value2 & " at " & _
                          UBound(Filter(dict.Item(ky), .Cells(1, c).Value2))
                    End If
                    'worksheet MATCH method of 'not found in array'
                    'Case insensitive search - foo == FOO
                    If IsError(Application.Match(.Cells(1, c).Value2, dict.Item(ky), 0)) Then
                        .Cells(1, c).EntireColumn.Delete
                    Else
                        Debug.Print .Cells(1, c).Value2 & " at " & _
                          Application.Match(.Cells(1, c).Value2, dict.Item(ky), 0)
                    End If
                Next c
            End With
        Next ky
    End With

    dict.RemoveAll: Set dict = Nothing

End Sub

请注意，我提供了两种方法来确定列标题标签是否在要保留的列数组中。一种区分大小写（数组过滤方法），另一种不区分大小写（工作表函数 MATCH 方法）。不区分大小写的搜索方法当前处于活动状态。