excel VBA基于多个表格中的标题行删除列

好的，所以我试图删除多个表单中的标题行中包含特定值的列。 如果我删除激活工作表过程，并将代码放在所需的工作表上，它工作正常，但这不会是一个选项。 我有大约100个使用xls模板创build的文件，我需要删除某些列。

以下是我想要激活包含标题值和要删除的列的工作表。

我在下面的示例中查找的值是RUA命中计数，RUA用法，RUA开始date，RUA结束date和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

此过程适用于ActiveWorkbook

它可以被编辑来处理一系列工作簿

它使用列标题的search条件填充字典

然后，它检查每个列标题，并在find匹配项时删除该列

 '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 

Answer 2

 '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