從多個工作表中刪除多列

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

下面以維持被處理作爲字典鍵與列標題標籤的陣列，以保持作爲關聯項工作表的列表的腳本字典對象。

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方法）。不區分大小寫的搜索方法目前處於活動狀態。