VBA日期函数优化：自动匹配对应周的Schedule工作簿

核心思路 #

通过计算当前日期对应的本周日和下周日（工作簿日期以周日结尾，对应未来1-2周日程），自动生成匹配的日期字符串，无需手动修改代码中的数值，即可定位目标工作簿。

已打开工作簿匹配版代码 #

适用于处理已经打开的SCHED工作簿：

Sub AutoFindSchedWorkbooks()
    Dim targetDates As Collection
    Dim currentDate As Date
    Dim thisSunday As Date
    Dim nextSunday As Date
    Dim dateStr As String
    Dim wb As Workbook
    Dim targetWbs As Collection
    
    Set targetDates = New Collection
    Set targetWbs = New Collection
    
    ' 获取当前系统日期
    currentDate = Date
    
    ' 计算本周日（若当天是周日则直接取当天，否则取本周日）
    thisSunday = currentDate - Weekday(currentDate, vbSunday) + 7
    ' 计算下周日
    nextSunday = thisSunday + 7
    
    ' 转换为工作簿命名的日期格式（示例为MM.DD.YY，需和实际文件名格式一致）
    targetDates.Add Format(thisSunday, "MM.DD.YY")
    targetDates.Add Format(nextSunday, "MM.DD.YY")
    
    ' 遍历所有已打开的工作簿，匹配目标名称
    For Each wb In Workbooks
        For Each dateStr In targetDates
            ' 用Like模糊匹配，兼容带后缀（如.xlsx）的文件名
            If wb.Name Like "SCHED " & dateStr & "*" Then
                targetWbs.Add wb
                Exit For ' 找到匹配后跳出当前日期循环
            End If
        Next dateStr
    Next wb
    
    ' 执行后续业务逻辑（替换为你的实际处理代码）
    If targetWbs.Count > 0 Then
        MsgBox "找到" & targetWbs.Count & "个目标工作簿：" & vbCrLf & _
               Join(GetWbNames(targetWbs), vbCrLf)
        ' 示例：逐个处理匹配到的工作簿
        For Each wb In targetWbs
            ' wb.Activate
            ' 这里写入你的数据处理、复制等逻辑
        Next wb
    Else
        MsgBox "未找到匹配的SCHED工作簿"
    End If
End Sub

' 辅助函数：提取工作簿名称列表用于提示
Function GetWbNames(wbs As Collection) As Variant
    Dim arr() As String
    Dim i As Integer
    ReDim arr(1 To wbs.Count)
    
    For i = 1 To wbs.Count
        arr(i) = wbs(i).Name
    Next i
    
    GetWbNames = arr
End Function

指定文件夹查找版代码 #

适用于从指定文件夹中查找并打开目标工作簿：

Sub AutoFindSchedWorkbooksFromFolder()
    Dim targetDates As Collection
    Dim currentDate As Date
    Dim thisSunday As Date
    Dim nextSunday As Date
    Dim dateStr As String
    Dim folderPath As String
    Dim fileName As String
    Dim targetFiles As Collection
    
    Set targetDates = New Collection
    Set targetFiles = New Collection
    
    ' 修改为SCHED工作簿实际存放的文件夹路径
    folderPath = "C:\Your\Schedule\Directory\"
    ' 确保路径末尾带反斜杠
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    currentDate = Date
    thisSunday = currentDate - Weekday(currentDate, vbSunday) + 7
    nextSunday = thisSunday + 7
    
    targetDates.Add Format(thisSunday, "MM.DD.YY")
    targetDates.Add Format(nextSunday, "MM.DD.YY")
    
    ' 遍历文件夹中所有xls/xlsx格式文件
    fileName = Dir(folderPath & "SCHED *.xls*")
    Do While fileName <> ""
        For Each dateStr In targetDates
            If fileName Like "SCHED " & dateStr & "*" Then
                targetFiles.Add folderPath & fileName
                Exit For
            End If
        Next dateStr
        fileName = Dir
    Loop
    
    ' 打开并处理找到的工作簿
    If targetFiles.Count > 0 Then
        MsgBox "找到" & targetFiles.Count & "个目标工作簿：" & vbCrLf & _
               Join(GetArrayFromCollection(targetFiles), vbCrLf)
        Dim filePath As Variant
        For Each filePath In targetFiles
            Workbooks.Open filePath
            ' 这里写入你的处理逻辑
        Next filePath
    Else
        MsgBox "指定文件夹中未找到匹配的SCHED工作簿"
    End If
End Sub

' 辅助函数：将集合转换为数组用于提示
Function GetArrayFromCollection(col As Collection) As Variant
    Dim arr() As Variant
    ReDim arr(1 To col.Count)
    Dim i As Integer
    For i = 1 To col.Count
        arr(i) = col(i)
    Next i
    GetArrayFromCollection = arr
End Function

关键调整说明 #

• 日期格式匹配：如果你的SCHED工作簿日期格式是DD.MM.YY或MM.DD.YYYY，修改代码中Format函数的参数即可，比如Format(thisSunday, "DD.MM.YY")
• 模糊匹配：用Like运算符兼容文件名后带后缀（如.xlsx）或其他附加字符的情况
• 批量处理：代码会自动收集所有匹配的工作簿，你可以直接在循环中添加业务逻辑，无需逐个手动操作

内容的提问来源于stack exchange，提问作者Rose