适配周末规则的Excel VBA动态文件读取代码修改咨询

核心逻辑 #

• 用Weekday(Date, vbMonday)判断当前是否为周一：返回值为1时代表当天是周一，需要额外处理周六、周日两天的数据，加上周五共3天；其余时间仅处理前一天的数据
• 将原有单次处理前一天日期的逻辑封装为循环，遍历所有待处理日期
• 优化原代码中冗余的Select/Activate操作，减少不必要的窗口切换，提升运行效率
• 补全原代码中缺失的YearString变量定义，避免运行报错

导入数据主宏 #

Sub ImportDailyData()
    ' 关闭屏幕更新和告警，提升运行速度
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    ' 生成待处理的日期列表
    Dim processDates() As Date
    Dim dateCount As Integer
    If Weekday(Date, vbMonday) = 1 Then
        ' 周一处理周五、周六、周日共3天数据
        dateCount = 3
        ReDim processDates(1 To dateCount)
        processDates(1) = Date - 3 ' 周五
        processDates(2) = Date - 2 ' 周六
        processDates(3) = Date - 1 ' 周日
    Else
        ' 非周一仅处理前1天数据
        dateCount = 1
        ReDim processDates(1 To dateCount)
        processDates(1) = Date - 1
    End If

    ' 行偏移量，避免多天数据粘贴时互相覆盖
    Dim rowOffset As Integer
    rowOffset = 0

    Dim curDate As Date
    ' 遍历所有待处理日期
    For Each curDate In processDates
        ' 生成当前处理日期对应的各类格式字符串
        Dim MonthYearString As String
        MonthYearString = Format(curDate, "mmm yyyy")
        Dim YearString As String
        YearString = Year(curDate)
        Dim DateString As String
        DateString = Format(curDate, "dd-mm-yyyy")
        Dim DateStringFS As String
        DateStringFS = Format(curDate, "dd.mm.yy")

        ' 拼接文件目录
        Dim directory As String
        directory = "C:\Users\XXXX-XXXX\Dropbox (SHG)\Alteryx Output\Daily Finance & Revenue Data\1. Daily Occupancy Output\IYO-Indigo York\" & YearString & "\" & MonthYearString & "\" & DateString & "\"
        Dim fileName As String
        fileName = Dir(directory & "*manager*.csv")

        ' 循环处理当前目录下的所有匹配文件
        Do While fileName <> ""
            Workbooks.Open directory & fileName, local:=True
            Dim sheet As Worksheet
            For Each sheet In Workbooks(fileName).Worksheets
                ' 直接复制粘贴，省略冗余的选中激活操作
                Workbooks(fileName).Sheets(sheet.Name).Rows("1:2").Copy
                Workbooks("YORYK Daily Report " & DateStringFS & ".xlsb").Sheets("Actual data").Rows(4 + rowOffset & ":" & 5 + rowOffset).PasteSpecial Paste:=xlPasteValues
                Application.CutCopyMode = False
            Next sheet
            ' 处理完关闭源文件，不保存修改
            Workbooks(fileName).Close SaveChanges:=False
            fileName = Dir()
        Loop

        ' 调用数据存储宏，传入当前处理的日期
        Call test(curDate)
        ' 行偏移+2，下一天数据粘贴到当前数据下方
        rowOffset = rowOffset + 2
    Next curDate

    ' 恢复屏幕更新和告警
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

数据存储宏 #

Sub test(curDate As Date)
    Range("H8:M8").Copy
    Dim cell As Range
    For Each cell In Range("A1:A5")
        ' 匹配传入的待处理日期
        If cell.Value = curDate Then
            cell.Offset(0, 1).PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False
            ' 找到匹配项后直接退出循环，提升效率
            Exit For
        End If
    Next cell
End Sub

• 如果你的报告文件名称固定、不需要随日期变化，可以把主宏中Workbooks("YORYK Daily Report " & DateStringFS & ".xlsb")里的DateStringFS变量去掉，避免找不到文件
• 若三天的数据需要粘贴到固定行而非逐行下移，删除rowOffset相关的变量定义和赋值逻辑即可
• 运行前请确认路径中的YearString生成规则和你实际的文件夹命名规则一致

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