VBA遍历网络文件夹时按当前年月筛选的代码修复需求

我用VBA遍历网络路径下的文件夹及子文件夹，提取数据到目标工作表。现有代码可正常运行，但遍历所有文件夹耗时过长，希望添加条件：仅处理文件夹名（格式为yyyymmdd）属于当前年月的文件夹，自行修改的代码无法运行，请求修复该筛选逻辑。

尝试修改的错误代码片段 #

While folder <> ""
    If IsDateFormat(folder, dateFormat) Then
        Dim currentYear As String: currentYear = Year(Date)
        Dim currentMonth As String: currentMonth = Format(Month(Date), "00")
    Dim folderYear As String: folderYear = Left(folder, 4)
        Dim folderMonth As String: folderMonth = Mid(folder, 5, 2)
        If folderYear = currentYear And folderMonth = currentMonth Then
            fldrStack.Push folder
        End If
    End If
    folder = Dir()
Wend

原有可运行完整代码 #

Sub Reporting()
    Dim networkFolder As String: networkFolder = "\\folder1\folder2\"
    Dim folder As String
    Dim subfolder As String
    Dim filePath As String
    Dim wb As Workbook
    Dim destWb As Workbook '目标工作簿：存放粘贴数据的工作簿
    Dim destSheet As Worksheet '目标工作表：最终处理完成的工作表
    Dim lastRow As Long
    Dim cell As Range
    Dim sourceWs As Worksheet '源工作表：提取数据的来源表
    Dim destRow As Long
    Dim folderDate As String
    Dim dateFormat As String: dateFormat = "yyyymmdd"
    Dim dataRange As Range
    Dim file As String
    Dim dateValue As Variant 'For Each循环需声明为Variant
    Dim r As Long
    Dim i As Long
    Dim j As Long
    
    Application.ScreenUpdating = False

    
    ' 打开目标工作簿
    On Error Resume Next
    Set destWb = Workbooks("endfile.xlsm")
    If destWb Is Nothing Then
        MsgBox "目标工作簿'endfile.xlsm'未打开。", vbCritical
        Exit Sub
    End If
    On Error GoTo 0
    
    ' 设置目标工作表
    On Error Resume Next
    Set destSheet = destWb.Sheets("Sheet2")
    If destSheet Is Nothing Then
        MsgBox "目标工作簿中不存在'Sheet1'工作表。", vbCritical
        Exit Sub
    End If
    On Error GoTo 0
    
    destRow = 1
 
    '''识别所有文件夹
    Dim fldrStack As Object: Set fldrStack = CreateObject("System.Collections.Stack")
    
    folder = Dir(networkFolder, vbDirectory)
    
    While folder <> ""
        If IsDateFormat(folder, dateFormat) Then fldrStack.Push folder
        folder = Dir()
    Wend
    '''
    
    '''遍历识别到的文件夹
    While fldrStack.Count > 0
        folder = fldrStack.Pop()
        
        folderDate = Format(CDate(Left(folder, 4) & "-" & Mid(folder, 5, 2) & "-" & Right(folder, 2)), "mm/dd/yyyy")
        subfolder = networkFolder & folder & "\\Reporting\\Daily_Reports\\"
        file = Dir(subfolder & "Summary_Report_" & folder & ".xls")

        If file <> "" Then
            filePath = subfolder & file
            Set wb = Workbooks.Open(filePath)
            Set sourceWs = wb.Sheets(1)

            ' 定义数据范围
            lastRow = sourceWs.Cells(sourceWs.Rows.Count, "A").End(xlUp).Row
            Set dataRange = sourceWs.Range("A6:AT" & lastRow)

            ' 应用筛选
            dataRange.AutoFilter Field:=1, Criteria1:="Manual"
            dataRange.AutoFilter Field:=44, Criteria1:="=*Regular*", Operator:=xlAnd

            ' 复制筛选后的数据到目标工作表
            On Error Resume Next
            Set dataRange = sourceWs.Range("A7:AT" & lastRow).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0

            If Not dataRange Is Nothing Then
                dataRange.Copy destSheet.Cells(destRow, 2) '从B列开始粘贴，留A列放日期
                
                ' 为每一行添加文件夹日期
                For Each cell In destSheet.Range(destSheet.Cells(destRow, 2), destSheet.Cells(destSheet.Rows.Count, 2).End(xlUp))
                    If cell.Value <> "" Then
                        cell.Offset(0, -1).Value = folderDate
                    End If
                Next cell

                destRow = destSheet.Cells(destSheet.Rows.Count, "B").End(xlUp).Row + 1
            End If

            wb.Close SaveChanges:=False
        End If
    Wend
    
    '''清理资源
    fldrStack.Clear
    Set fldrStack = Nothing
    
    '''插入新列用于数据转换
    destSheet.Columns("A").Resize(, 89).Insert
    
    '''数据转换操作
    For i = 1 To destRow - 1
        destSheet.Cells(i, "B").Value = "Manual"
        destSheet.Cells(i, "C").Value = "Regular"
        destSheet.Cells(i, "D").Value = "0"
        destSheet.Cells(i, "H").Value = 0
        destSheet.Cells(i, "I").Value = "IT"
        destSheet.Cells(i, "L").Value = "Normal"
        destSheet.Cells(i, "CB").Value = 0
        destSheet.Cells(i, "CC").Value = "CS"
        destSheet.Cells(i, "CD").Value = "MATT"
        destSheet.Cells(i, "A").Value = destSheet.Cells(i, "CL").Value
        destSheet.Cells(i, "J").Value = destSheet.Cells(i, "DK").Value
        destSheet.Cells(i, "K").Value = destSheet.Cells(i, "DJ").Value
        destSheet.Cells(i, "O").Value = destSheet.Cells(i, "DN").Value * (-1)
        destSheet.Cells(i, "V").Value = destSheet.Cells(i, "DO").Value * (-1)
        destSheet.Cells(i, "S").Value = (destSheet.Cells(i, "V").Value / destSheet.Cells(i, "O").Value) * 100
        destSheet.Cells(i, "W").Value = destSheet.Cells(i, "DG").Value * 100
    Next i
     
End Sub

'验证文件夹名是否符合日期格式
Function IsDateFormat(folderName As String, dateFormat As String) As Boolean
    IsDateFormat = (Len(folderName) = Len(dateFormat)) And IsNumeric(Left(folderName, 4)) And IsNumeric(Mid(folderName, 5, 2)) And IsNumeric(Right(folderName, 2))
End Function

修复后的筛选逻辑代码 #

你的修改代码存在两个问题：一是变量声明位置导致语法错误，二是循环内重复计算当前年月造成冗余。修复后的代码如下，替换原有代码中识别所有文件夹的部分：

'''识别所有文件夹
Dim fldrStack As Object: Set fldrStack = CreateObject("System.Collections.Stack")
' 提前计算当前年月，避免循环内重复计算
Dim currentYear As String: currentYear = CStr(Year(Date))
Dim currentMonth As String: currentMonth = Format(Month(Date), "00")

folder = Dir(networkFolder, vbDirectory)

While folder <> ""
    If IsDateFormat(folder, dateFormat) Then
        Dim folderYear As String: folderYear = Left(folder, 4)
        Dim folderMonth As String: folderMonth = Mid(folder, 5, 2)
        ' 仅将当前年月的文件夹加入处理栈
        If folderYear = currentYear And folderMonth = currentMonth Then
            fldrStack.Push folder
        End If
    End If
    folder = Dir()
Wend
'''

修复说明 #

1. 变量优化：将currentYear和currentMonth的计算移到循环外，避免重复调用日期函数，提升运行效率。
2. 语法修正：调整变量声明的位置，确保If块内的代码结构符合VBA语法规范。
3. 筛选逻辑生效：只有文件夹的年份和月份与当前年月完全匹配时，才会被加入处理栈，跳过其他年月的文件夹，大幅减少遍历时间。

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