VBA CSV文件合并故障排查：需从20240603文件开始合并

问题描述 #

现有VBA代码意图从指定文件夹中提取符合命名格式gcts_all_tran_data_YYYYMMDD.csv的CSV文件数据，从目标文件第1079行开始粘贴并执行后续调整操作，要求仅处理2024年6月3日及之后的文件。但运行代码后仅弹出完成提示框，无任何数据复制粘贴动作。原代码如下：

Sub ConsolidateData()
    Dim wsDest As Worksheet
    Dim wbDest As Workbook
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim LastRowDest As Long
    Dim LastRowSource As Long
    Dim FileName As String
    Dim FolderPath As String
    Dim StartRow As Long
    Dim EndRow As Long
    Dim FormulaCell As Range
    Dim i As Long
    Dim FileDate As Date
    Dim FileDateString As String

    ' Destination workbook and worksheet
    Set wbDest = Workbooks.Open("K:\folder1\destination.xlsm")
    Set wsDest = wbDest.Sheets("Data")

    ' Folder containing the CSV files
    FolderPath = "C:\Users\folder2\"

    ' Initialize variables
    FileName = Dir(FolderPath & "gcts_all_tran_data_*.csv")

    ' Start pasting data at row 1079
    LastRowDest = 1078

    ' Loop through all CSV files in the folder
    Do While FileName <> ""
        ' Extract the date from the filename (YYYYMMDD format)
        FileDateString = Mid(FileName, 18, 8)

        ' Check if the extracted string is a valid date
        If IsNumeric(FileDateString) And Len(FileDateString) = 8 Then
            FileDate = DateSerial(CLng(Mid(FileDateString, 1, 4)), CLng(Mid(FileDateString, 5, 2)), CLng(Mid(FileDateString, 7, 2)))

            ' Check if the file date is on or after 20240603
            If FileDate >= DateSerial(2024, 6, 3) Then
                ' Open the CSV file
                Set wbSource = Workbooks.Open(FolderPath & FileName)
                Set wsSource = wbSource.Sheets(1)

                ' Find the last row of the source worksheet
                LastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row

                ' Apply filter to column E and copy the filtered data
                wsSource.Range("A1:P" & LastRowSource).AutoFilter Field:=5, Criteria1:="Bob"

                On Error Resume Next ' Skip to next file if there are no visible cells
                If wsSource.Range("A2:A" & LastRowSource).SpecialCells(xlCellTypeVisible).Count > 1 Then
                    ' Find the last row in the destination worksheet before appending new data
                    LastRowDest = LastRowDest + 1 ' Move to the next row for pasting

                    ' Copy the data without headers
                    wsSource.Range("A2:P" & LastRowSource).SpecialCells(xlCellTypeVisible).Copy
                    wsDest.Cells(LastRowDest, 1).PasteSpecial Paste:=xlPasteValues
                    Application.CutCopyMode = False ' Clear the clipboard to avoid the message

                    ' Update LastRowDest to the new last row after pasting
                    LastRowDest = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row
                End If
                On Error GoTo 0 ' Reset error handling

                ' Close the source workbook without saving
                wbSource.Close False
            End If
        End If

        ' Get the next file
        FileName = Dir
    Loop

    ' Extend formulas in column Q starting from row 1079
    StartRow = 1079
    EndRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row

    For i = StartRow To EndRow
        wsDest.Cells(i, "Q").Value = wsDest.Cells(i - 1, "Q").Value + wsDest.Cells(i, "G").Value
    Next i

    ' Sort the data in the destination worksheet by column K (oldest to newest) starting from row 1079
    With wsDest.Sort
        .SortFields.Clear
        .SortFields.Add Key:=wsDest.Range("K1079:K" & EndRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange wsDest.Range("A1079:R" & EndRow)
        .Header = xlNo
        .Apply
    End With

    ' Delete rows where column K is [NULL] and column G is equal to 0 starting from row 1079
    For i = EndRow To 1079 Step -1
        With wsDest
            If .Cells(i, "K").Value = "[NULL]" And .Cells(i, "G").Value = 0 Then
                .Rows(i).Delete
            End If
        End With
    Next i

    ' Save and close the destination workbook
    wbDest.Save

    ' Clean up
    Set wbDest = Nothing
    Set wsDest = Nothing
    Set wbSource = Nothing
    Set wsSource = Nothing

    MsgBox "Data consolidation complete!"
End Sub

问题排查关键点 #

• 文件名日期提取索引错误：gcts_all_tran_data_的字符长度为19，原代码用Mid(FileName, 18, 8)提取日期会导致截取的字符串无效，所有符合条件的文件都会被跳过。
• 日期验证缺失错误处理：即使日期字符串是8位数字，也可能是无效日期（如20241301），DateSerial会抛出错误导致流程中断，且无捕获逻辑。
• 过滤后数据判断逻辑过严：原代码判断Count > 1，若过滤后只有1行有效数据会被直接跳过，无法正常复制。
• 无调试反馈：代码没有中间执行提示，无法确认是否找到目标文件或进入数据处理环节。

修正后的代码 #

Sub ConsolidateData()
    Dim wsDest As Worksheet
    Dim wbDest As Workbook
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim LastRowDest As Long
    Dim LastRowSource As Long
    Dim FileName As String
    Dim FolderPath As String
    Dim StartRow As Long
    Dim EndRow As Long
    Dim i As Long
    Dim FileDate As Date
    Dim FileDateString As String
    Dim hasProcessed As Boolean ' 标记是否处理过有效数据
    Dim visibleRange As Range

    ' 全局错误捕获
    On Error GoTo ErrorHandler

    ' 目标文件与工作表
    Set wbDest = Workbooks.Open("K:\folder1\destination.xlsm")
    Set wsDest = wbDest.Sheets("Data")

    ' 源文件路径处理（确保末尾有斜杠）
    FolderPath = "C:\Users\folder2\"
    If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"

    ' 初始化变量
    FileName = Dir(FolderPath & "gcts_all_tran_data_*.csv")
    LastRowDest = 1078 ' 从1079行开始粘贴
    hasProcessed = False

    ' 遍历所有CSV文件
    Do While FileName <> ""
        ' 提取日期：gcts_all_tran_data_ 是19个字符，从第20位取8位
        FileDateString = Mid(FileName, 20, 8)

        ' 验证日期有效性
        If IsNumeric(FileDateString) And Len(FileDateString) = 8 Then
            ' 捕获无效日期转换错误
            On Error Resume Next
            FileDate = DateSerial(CLng(Mid(FileDateString, 1, 4)), _
                                 CLng(Mid(FileDateString, 5, 2)), _
                                 CLng(Mid(FileDateString, 7, 2)))
            On Error GoTo ErrorHandler

            ' 检查日期是否符合要求
            If FileDate >= DateSerial(2024, 6, 3) Then
                hasProcessed = True
                Debug.Print "正在处理文件：" & FileName ' 调试输出

                ' 打开源CSV文件
                Set wbSource = Workbooks.Open(FolderPath & FileName)
                Set wsSource = wbSource.Sheets(1)

                ' 获取源文件最后一行
                LastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row

                ' 清除原有过滤
                wsSource.AutoFilterMode = False

                ' 按E列过滤"Bob"的数据
                wsSource.Range("A1:P" & LastRowSource).AutoFilter Field:=5, Criteria1:="Bob"

                ' 获取可见数据范围
                On Error Resume Next
                Set visibleRange = wsSource.Range("A2:P" & LastRowSource).SpecialCells(xlCellTypeVisible)
                On Error GoTo ErrorHandler

                ' 若有可见数据则复制粘贴
                If Not visibleRange Is Nothing Then
                    visibleRange.Copy
                    wsDest.Cells(LastRowDest + 1, 1).PasteSpecial Paste:=xlPasteValues
                    Application.CutCopyMode = False

                    ' 更新目标文件最后一行
                    LastRowDest = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row
                    Debug.Print "已粘贴数据，目标表最后一行：" & LastRowDest
                End If

                ' 关闭源文件不保存
                wbSource.Close False
            End If
        End If

        ' 获取下一个文件
        FileName = Dir
    Loop

    ' 若处理过有效数据，执行后续调整
    If hasProcessed Then
        StartRow = 1079
        EndRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row

        ' 填充Q列公式（优化为批量填充）
        If EndRow >= StartRow Then
            wsDest.Cells(StartRow, "Q").Value = wsDest.Cells(StartRow - 1, "Q").Value + wsDest.Cells(StartRow, "G").Value
            wsDest.Range("Q" & StartRow & ":Q" & EndRow).DataSeries Rowcol:=xlColumns, Type:=xlLinear, _
                                                                         Date:=xlDay, Step:=1, Stop:=EndRow, Trend:=False
        End If

        ' 按K列升序排序
        If EndRow >= StartRow Then
            With wsDest.Sort
                .SortFields.Clear
                .SortFields.Add Key:=wsDest.Range("K" & StartRow & ":K" & EndRow), _
                                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .SetRange wsDest.Range("A" & StartRow & ":R" & EndRow)
                .Header = xlNo
                .Apply
            End With

            ' 删除K列为[NULL]且G列为0的行
            For i = EndRow To StartRow Step -1
                With wsDest
                    If .Cells(i, "K").Value = "[NULL]" And .Cells(i, "G").Value = 0 Then
                        .Rows(i).Delete
                    End If
                End With
            Next i
        End If

        wbDest.Save
        MsgBox "数据合并完成，已处理有效文件！"
    Else
        MsgBox "未找到符合条件的文件，或文件中无有效数据！"
    End If

Cleanup:
    ' 释放对象
    Set wbDest = Nothing
    Set wsDest = Nothing
    Set wbSource = Nothing
    Set wsSource = Nothing
    Set visibleRange = Nothing
    Exit Sub

ErrorHandler:
    MsgBox "执行出错：" & Err.Description
    Resume Cleanup
End Sub

修正说明 #

1. 修复日期提取索引：将Mid(FileName, 18, 8)改为Mid(FileName, 20, 8)，匹配文件名中日期的正确位置。
2. 增加错误处理：添加全局错误捕获及日期转换时的局部错误处理，避免单个文件出错导致流程中断。
3. 优化数据判断逻辑：通过判断visibleRange是否存在，替代原有的Count > 1，确保单行有效数据也能被处理。
4. 增加调试反馈：使用Debug.Print输出处理状态，方便排查问题；添加处理标记，根据执行结果给出对应提示。
5. 优化公式填充：使用DataSeries替代循环填充，提升执行效率。
6. 完善路径处理：自动补全文件夹路径末尾的斜杠，避免文件名拼接错误。

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