删除多个工作簿中多个工作表中的多个列

Question

我必须更新数百个 Excel 工作簿。每个工作簿有多个工作表（数量不限，最多 50 个）。

这个想法是，使用 VBA 代码 (Excel 2010) 遍历所有工作表并根据条件删除整个列。

每个工作表都有一个标题栏，开头为：

日期； 2024年9月20日； 2023-02-06 ; 2020-01-01 ; 2019-02-09 ; 1999-09-09 等等。

日期可变。

我想删除 2019 年或更早的所有列。

这是我使用其他帖子中的答案得出的结论。
它不会处理所有工作表中的所有列。我得跑好几次
此外，这些列不会被删除。该列中的数据被清除，但空白列仍然存在。

Dim a As Long, w As Long, match1 As String
With ThisWorkbook
    For w = 1 To .Worksheets.Count
        With Worksheets(w)
            
        For i = 50 To 1 Step -1
            match1 = CStr(Cells(1, i))
            If match1 Like "201?-*" Then
                Columns(i).EntireColumn.Delete
            End If
            If match1 Like "200?-*" Then
                Columns(i).EntireColumn.Delete
            End If
            If match1 Like "199?-*" Then
                Columns(i).EntireColumn.Delete
            End If
            If match1 Like "198?-*" Then
                Columns(i).EntireColumn.Delete
            End If            
        Next i
        End With
    Next w
End With

Answer 1

除了匆忙制作的包含三个电子表格的文件夹之外，这还没有经过彻底的测试，所以我建议谨慎行事，并首先在一些虚拟数据上进行测试，以防万一：

Sub DeleteOldDateColumnsInDirectory()
    Dim folderPath As String
    Dim fileName As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim col As Integer
    Dim headerDate As Date
    
    ' Specify the folder path (update this to your directory)
    folderPath = "C:\folderpath\etc\"
    
    ' Disable screen updating and automatic calculations for better performance
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' Get the first .xlsx file in the folder
    fileName = Dir(folderPath & "*.xlsx")
    
    ' Loop through each file in the folder
    Do While fileName <> ""
        ' Open the workbook
        Set wb = Workbooks.Open(folderPath & fileName)
        
        ' Loop through each worksheet in the workbook
        For Each ws In wb.Worksheets
            ' Start from the last column and work backwards
            For col = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column To 1 Step -1
                On Error Resume Next
                ' Try to interpret the header as a date
                headerDate = CDate(ws.Cells(1, col).Value)
                On Error GoTo 0
                
                ' If it’s a date and 2019 or earlier, delete the column
                If IsDate(headerDate) And Year(headerDate) <= 2019 Then
                    ws.Columns(col).Delete
                End If
            Next col
        Next ws
        
        ' Save and close the workbook
        wb.Close SaveChanges:=True
        
        ' Move to the next file
        fileName = Dir
    Loop
    
    ' Re-enable screen updating and calculations
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "Columns deleted in all workbooks in the folder."
End Sub