VBA跨工作表粘贴值时英式日期转美式日期的问题求助

问题描述 #

我编写的VBA代码用于打开指定目录下最新的CSV文件，筛选数据后复制粘贴到主工作簿。两个文件的E列均为英式日期格式，但粘贴后主文件中的日期自动转为美式格式——例如原日期02/10/2022（日期序列值44836，对应2022年10月2日），粘贴后变为10/02/2022（序列值44602，对应2022年2月10日），整列日期均受此影响。

我怀疑问题出在以下代码段：

Workbooks.Open Filename:=MyDir & myMostRecentFile
    Range("A1").AutoFilter Field:=3, Criteria1:="PRD"
    Range("A2", Range("A2").End(xlToRight).End(xlDown)).Copy
    wb.Sheets("D").Range("A70").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
ActiveWorkbook.Close savechanges:=False

尝试过以下无效方案：

Columns("E").Copy
Columns("E").PasteSpecial Paste:=xlPasteValues
Columns("E").NumberFormat = "@"
Range("E1", Range("E" & Rows.Count).End(xlUp)).NumberFormat = "dd/mm/yyyy"

完整代码如下：

Sub D_ImportAutoReport()

Dim myFile As String, myRecentFile As String, myMostRecentFile As String
Dim recentDate As Date
Dim MyDir As String
Dim fileExtension As String
Dim fileFilter As String
Dim wb As Workbook
Dim wbImp As Workbook

Application.ScreenUpdating = False

Set wb = ThisWorkbook
wb.Sheets("D").Range("A70:Q337").ClearContents

MyDir = "Q:\TEST\Scheduled Reports\"
fileExtension = "*.csv*"
fileFilter = "PRD*"

myFile = Dir(MyDir & fileFilter & fileExtension)

If myFile <> "" Then
    myRecentFile = myFile
    recentDate = FileDateTime(MyDir & myFile)
        Do While myFile <> ""
            If FileDateTime(MyDir & myFile) > recentDate Then
                myRecentFile = myFile
                recentDate = FileDateTime(MyDir & myFile)
            End If
            myFile = Dir
        Loop
End If

myMostRecentFile = myRecentFile

Workbooks.Open Filename:=MyDir & myMostRecentFile
    Range("A1").AutoFilter Field:=3, Criteria1:="PRD"
    Range("A2", Range("A2").End(xlToRight).End(xlDown)).Copy
    wb.Sheets("D").Range("A70").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
ActiveWorkbook.Close savechanges:=False

Application.ScreenUpdating = True
End Sub

解决方案 #

问题核心是CSV为纯文本文件，Excel打开时会根据系统区域设置自动解析日期。即便原文件是英式日期，若系统区域为美式，Excel会错误颠倒日/月顺序，导致日期序列值直接改变，后续修改格式仅能调整显示，无法修正底层的序列值。

方法1：打开CSV时强制使用英式区域解析 #

修改Workbooks.Open语句，添加Local:=True参数（若系统区域已设置为英式，此参数会让Excel按区域规则解析日期）：

' 打开文件时指定Local参数
Set wbImp = Workbooks.Open(Filename:=MyDir & myMostRecentFile, Local:=True)
' 后续筛选、复制代码不变
Range("A1").AutoFilter Field:=3, Criteria1:="PRD"
Range("A2", Range("A2").End(xlToRight).End(xlDown)).Copy
wb.Sheets("D").Range("A70").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
wbImp.Close savechanges:=False

方法2：用ADODB直接读取CSV（最可靠） #

绕过Excel的自动解析逻辑，用ADODB读取CSV并直接写入数据，可指定日期格式：

' 替换原打开文件、复制粘贴的代码段
Dim conn As Object, rs As Object
Dim destRange As Range
Set conn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
Set destRange = wb.Sheets("D").Range("A70")

' 连接CSV文件，指定日期格式为dd/mm/yyyy
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & MyDir & ";Extended Properties=""Text;HDR=Yes;FMT=Delimited;IMEX=1;DateTimeFormat=dd/mm/yyyy"";"

' 执行筛选，替换[Column3]为CSV中第三列的实际表头
rs.Open "SELECT * FROM [" & myMostRecentFile & "] WHERE [Column3]='PRD'", conn

' 将筛选后的数据写入主工作簿
If Not rs.EOF Then destRange.CopyFromRecordset rs

' 清理对象
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing

方法3：提前设置目标列格式并粘贴值和格式 #

若坚持使用复制粘贴，先将目标列设置为英式日期格式，再粘贴值和格式而非仅值：

' 提前设置目标区域的E列为英式日期格式
wb.Sheets("D").Range("E70:E337").NumberFormat = "dd/mm/yyyy"
' 复制后粘贴值和格式
wb.Sheets("D").Range("A70").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

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