Excel宏运行后日期格式异常致销售统计公式失效求助

核心问题原因 #

• 使用Workbooks.Open直接打开CSV时，Excel会依据系统区域设置自动识别日期格式。若CSV中的日期为dd/mm/yyyy hh:mm格式，但系统默认日期格式是mm/dd/yyyy，Excel会错误颠倒日和月（比如12/01/2025会被解析为1月12日而非12月1日）。
• 后续设置NumberFormat仅修改单元格显示格式，无法修正已错误的日期底层值，导致统计公式识别失败。手动复制正常是因为手动粘贴时可选择匹配目标格式，而宏里的xlPasteValues直接导入了错误解析后的数值。

修复步骤与代码修改 #

1. 替换CSV打开方式：用OpenText指定导入格式 #

放弃Workbooks.Open，改用Workbooks.OpenText，明确指定分隔符，并将日期列（第129列）设为文本格式导入，避免Excel自动解析错误。

2. 手动转换文本日期为正确的日期值 #

导入后，将文本格式的日期转换为Excel可识别的日期值，确保dd/mm/yyyy hh:mm格式被正确解析。

3. 修正文件夹路径的语法错误 #

原代码中FolderPath = FolderPath & "\""多了一个引号，导致路径错误，需修正为FolderPath = FolderPath & "\"。

修复后的完整代码 #

Sub ProcessAndExportWorkbook()
    Dim FolderPath As String
    Dim FileName As String
    Dim CsvWorkbook As Workbook
    Dim CsvSheet As Worksheet
    Dim ActiveWb As Workbook
    Dim DestinationSheet As Worksheet
    Dim NewWb As Workbook
    Dim ws As Worksheet, wsCopy As Worksheet
    Dim SaveFolderPath As String
    Dim SaveFileName As String
    Dim LastUsedRow As Long, LastUsedColumn As Long
    Dim LastSunday As Date, HeaderDate As Date
    Dim HeaderRow As Range
    Dim ColToCopy As Long
    Dim CopyRange As Range
    Dim StartTime As Double
    Dim UserName As String
    Dim i As Long ' 用于遍历日期列转换
    
    ' Start timing
    StartTime = Timer
    
    ' Disable screen updating and events for performance
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    ' Set the active workbook
    Set ActiveWb = ActiveWorkbook
    
    ' Set folder paths
    ' Get the current user's username dynamically
    UserName = Environ("USERNAME")

    ' Build the dynamic folder paths - 修正引号错误
    FolderPath = "C:\Users\" & UserName
    If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"

    SaveFolderPath = "C:\Users\" & UserName
    If Right(SaveFolderPath, 1) <> "\" Then SaveFolderPath = SaveFolderPath & "\"
    SaveFileName = "2025_Weekly_Report_Test.xlsx"
    
    ' Calculate the last Sunday
    LastSunday = Date - Weekday(Date, vbMonday)
    
    ' Process CSV files
    FileName = Dir(FolderPath & "*.csv")
    Do While FileName <> ""
        Dim SheetName As String
        
        ' Determine which sheet to update based on filename
        Select Case True
            Case LCase(FileName) Like "addons*"
                SheetName = "Add-Ons"
            Case LCase(FileName) Like "entries*"
                SheetName = "Entries"
            Case LCase(FileName) Like "revenue*"
                SheetName = "Revenue"
            Case Else
                FileName = Dir
                GoTo NextFile
        End Select
        
        ' 替换为OpenText，指定导入格式：逗号分隔，第129列为文本
        Workbooks.OpenText _
            Filename:=FolderPath & FileName, _
            DataType:=xlDelimited, _
            Comma:=True, _
            FieldInfo:=Array(Array(1, xlGeneralFormat), Array(129, xlTextFormat)) ' 第1列通用，第129列文本
        Set CsvWorkbook = ActiveWorkbook
        Set CsvSheet = CsvWorkbook.Sheets(1)
        
        ' Find the target sheet in the active workbook
        On Error Resume Next
        Set DestinationSheet = ActiveWb.Sheets(SheetName)
        On Error GoTo 0
        
        If Not DestinationSheet Is Nothing Then
            ' Clear the target sheet
            DestinationSheet.Cells.Clear
        
            ' Find the last used row and column in the CSV sheet
            LastUsedRow = CsvSheet.Cells(CsvSheet.Rows.Count, 1).End(xlUp).Row
            LastUsedColumn = CsvSheet.Cells(1, CsvSheet.Columns.Count).End(xlToLeft).Column
        
            ' 先复制所有数据为值
            CsvSheet.Range(CsvSheet.Cells(1, 1), CsvSheet.Cells(LastUsedRow, LastUsedColumn)).Copy
            DestinationSheet.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
            
            ' 转换第129列的文本日期为正确的日期值
            On Error Resume Next
            With DestinationSheet.Columns(129)
                .NumberFormat = "dd/mm/yyyy hh:mm"
                ' 遍历行，转换文本为日期（假设第1行是表头，从第2行开始）
                For i = 2 To LastUsedRow
                    If .Cells(i, 1).Value <> "" Then
                        ' 按dd/mm/yyyy hh:mm解析文本
                        .Cells(i, 1).Value = CDate(Format(.Cells(i, 1).Value, "dd/mm/yyyy hh:mm"))
                    End If
                Next i
            End With
            On Error GoTo 0
            
            ' 复制格式
            CsvSheet.Range(CsvSheet.Cells(1, 1), CsvSheet.Cells(LastUsedRow, LastUsedColumn)).Copy
            DestinationSheet.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
        End If

        
        CsvWorkbook.Close SaveChanges:=False
NextFile:
        FileName = Dir
    Loop
    
    ' Convert columns to values up to and including the last Sunday
    For Each ws In ActiveWb.Sheets
        If ws.Name Like "LDN *" Or ws.Name = "Global" Or ws.Name = "Sales performance" Then
            ' Set header row (row 2)
            Set HeaderRow = ws.Rows(2)
            LastCol = HeaderRow.Cells(ws.Columns.Count).End(xlToLeft).Column
            
            ' Find the last column with a header <= last Sunday
            ColToCopy = 1
            For Each Cell In HeaderRow.Cells(1, 1).Resize(1, LastCol)
                If IsDate(Cell.Value) Then
                    HeaderDate = Cell.Value
                    If HeaderDate > LastSunday Then Exit For
                    ColToCopy = Cell.Column
                End If
            Next Cell
            
            ' Copy data to values in the identified range
            If ColToCopy > 0 Then
                LastUsedRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row ' Find the last used row in column A
                Set CopyRange = ws.Range(ws.Cells(3, 1), ws.Cells(LastUsedRow, ColToCopy)) ' Use only used rows

                CopyRange.Value = CopyRange.Value
            End If
        End If
    Next ws
    
    ' Create new workbook for export
    Set NewWb = Workbooks.Add
    
    
    ' Process relevant sheets in the active workbook
    For Each ws In ActiveWb.Sheets
        If ws.Name = "Overview" Or ws.Name = "Saved & Incomplete" Or ws.Name Like "LDN *" Or ws.Name = "Global" Or ws.Name = "Sales performance" Then
            ' Add sheet to the new workbook
            ws.Copy After:=NewWb.Sheets(NewWb.Sheets.Count)
            Set wsCopy = NewWb.Sheets(NewWb.Sheets.Count)
            
            ' Convert formulas to values
            wsCopy.UsedRange.Value = wsCopy.UsedRange.Value
        End If
    Next ws
    
    ' Delete Sheet1 if it exists
    On Error Resume Next
    Dim wsSheet1 As Worksheet
    Set wsSheet1 = NewWb.Sheets("Sheet1")
    If Not wsSheet1 Is Nothing Then
        Application.DisplayAlerts = False
        wsSheet1.Delete
        Application.DisplayAlerts = True
    End If
    On Error GoTo 0
    
    ' Hide and protect Sales Performance sheet
    On Error Resume Next
    Set wsCopy = NewWb.Sheets("Sales performance")
    On Error GoTo 0
    If Not wsCopy Is Nothing Then
        wsCopy.Visible = xlSheetHidden
        wsCopy.Protect Password:=" "
    End If
    
    ' Protect workbook structure
    NewWb.Protect Structure:=True, Password:="sales2025"
    
    ' Save the new workbook
    NewWb.SaveAs FileName:=SaveFolderPath & SaveFileName, FileFormat:=xlOpenXMLWorkbook
    NewWb.Close SaveChanges:=True
    
    ' Re-enable screen updating and events
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    
    ' Completion message
    MsgBox "Process completed in " & Format(Timer - StartTime, "0.00") & " seconds." & vbCrLf & _
           "File saved to: " & SaveFolderPath & SaveFileName, vbInformation
End Sub

关键修改说明 #

• OpenText导入设置：通过FieldInfo参数指定第129列为文本格式，阻止Excel自动解析日期，避免日月颠倒。
• 手动转换日期：将文本格式的日期用CDate结合Format强制按dd/mm/yyyy hh:mm解析，确保底层日期值正确。
• 路径修正：移除了文件夹路径末尾多余的引号，避免路径无效。

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