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

我试图从多个工作表中删除多个列，同时保留在列表中find的列。

例如，我有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

好的，这里是基本的代码。 在主程序中指定工作表和要删除的列。 设置在子程序中find标题的行。

 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对象，该对象维护一个工作表的列表，将其作为包含列标题数组的字典键来处理，以作为关联的项目 。

 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 

请注意，我已经包含了两种方法来确定列标题标签是否在要保留的列数组内。 一个是区分大小写的（数组Filter方法），另一个不是（工作表函数MATCH方法）。 不区分大小写的search方法目前处于活动状态。