Excel VBA刪除多張表中基於標題行的列

Question

好的，因此，我嘗試刪除多頁標題行中包含特定值的列。 如果我刪除了“激活工作表”過程，並將代碼放在所需的工作表上，它可以正常工作，但這不是一個選擇。 我有約100個使用xls模板創建的文件，我需要刪除某些列。

下面是我試圖激活包含標題值和要刪除的列的工作表的操作。

我在以下示例中尋找的值是RUA命中計數，RUA使用情況，RUA開始日期，RUA結束日期和RUA總天數。 全部說完后，將從每個工作簿中刪除大約50列。

Sub remove_columns()

Dim i As Integer

Worksheets("Sheet7").Activate
For i = ActiveSheet.Columns.Count To 1 Step -1
    If InStr(1, Cells(1, i), "RUA Hit Count") Then Columns(i).EntireColumn.Delete
Next i

Worksheets("Sheet5").Activate
For i = ActiveSheet.Columns.Count To 1 Step -1
    If InStr(1, Cells(1, i), "RUA Usage") Then Columns(i).EntireColumn.Delete
Next i

Worksheets("Sheet1").Activate
For i = ActiveSheet.Columns.Count To 1 Step -1
    If InStr(1, Cells(1, i), "RUA Start Date") Then Columns(i).EntireColumn.Delete
Next i

Worksheets("Sheet2").Activate
For i = ActiveSheet.Columns.Count To 1 Step -1
    If InStr(1, Cells(1, i), "RUA End Date") Then Columns(i).EntireColumn.Delete
Next i

Worksheets("Sheet3").Activate
For i = ActiveSheet.Columns.Count To 1 Step -1
    If InStr(1, Cells(1, i), "RUA Total Days") Then Columns(i).EntireColumn.Delete
Next i

 End Sub

Answer 1

'Process all workbooks in a given folder
' - remove specified columns
Sub Tester()
    Dim c As Collection, f, wb As Workbook

    Set c = GetExcels("C:\_Stuff\test") 'edit folder to suit
    For Each f In c
        Debug.Print f
        Set wb = Workbooks.Open(f)
        ProcessWorkbook wb
        wb.Close True 'save changes
    Next f
End Sub

'remove all unwanted columns from a workbook
Sub ProcessWorkbook(wb As Workbook)
    RemoveColumn wb.Worksheets("Sheet7"), "RUA Hit Count"
    RemoveColumn wb.Worksheets("Sheet5"), "RUA Usage"
    RemoveColumn wb.Worksheets("Sheet1"), "RUA Start Date"
    RemoveColumn wb.Worksheets("Sheet2"), "RUA End Date"
    RemoveColumn wb.Worksheets("Sheet3"), "RUA Total Days"
End Sub

'remove a column from a sheet if it exists
Sub RemoveColumn(sht As Worksheet, colName As String)
    Dim f As Range
    Set f = sht.Rows(1).Find(what:=colName, lookat:=xlWhole)
    If Not f Is Nothing Then f.EntireColumn.Delete
End Sub

'get a collection of all Excel filenames (inc. path) in a folder
Function GetExcels(sDir As String) As Collection
    Dim c As New Collection, f
    If Right(sDir, 1) <> "\" Then sDir = sDir & "\"
    f = Dir(sDir & "*.xlsx")
    Do While Len(f) > 0
        c.Add sDir & f
        f = Dir()
    Loop
    Set GetExcels = c
End Function

Answer 2

此過程適用於ActiveWorkbook

可以對其進行編輯以處理一系列工作簿

它使用列標題的搜索條件填充字典

然后，它檢查每個列標題，並在找到匹配項時刪除該列

'Tools->References
'Reference Microsoft Scripting Runtime

Dim intCount1 As Integer
Dim intCounter1 As Integer
Dim intColumnLast As Integer
Dim strHeader As String
Dim wsTemp As Worksheet
Dim dictColumnHeader As Dictionary

'Populate dictionary
Set dictColumnHeader = New Dictionary
With dictColumnHeader
    .Add Key:="RUA Hit Count", Item:=1
    .Add Key:="RUA Usage", Item:=2
    .Add Key:="RUA Start Date", Item:=3
    .Add Key:="RUA End Date", Item:=4
    .Add Key:="RUA Total Days", Item:=5
End With

For Each wsTemp In ActiveWorkbook.Sheets
    wsTemp.Activate
    intColumnLast = Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    intCount1 = 0
    'Check each column header to see if it matches bogus column headers loaded into dictionary
    For intCounter1 = intColumnLast To 1 Step -1
        'Assuming the header row is on row 1
        strHeader = Cells(1, intCounter1).Value
        If dictColumnHeader.Exists(strHeader) = True Then
            Cells(1, intCounter1).EntireColumn.Delete
        End If
    Next intCounter1
Next wsTemp