在另一个电子表格中复制粘贴值时，VBA 将英国日期更改为美国日期的问题

Question

我有一个代码可以打开最近的电子表格，复制数据并将其粘贴到主文件中。两个文件的 E 列中都有日期，始终采用英国格式。

但是，当将数据从最近的电子表格粘贴到主电子表格时，日期会转换为美国格式，例如02/10/2022 是 2022 年 10 月 2 日，单元格值为 44836，但它会被粘贴为 10/02/2022 的 10 FEB 2022 单元格值 44602。整个列都受此影响。

我看到其他用户为此苦苦挣扎，并尝试格式化为文本、格式化为日期、添加新列等，但没有任何解决办法。

我相信问题出在这一步：

  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

Answer 1

如果粘贴的数据看起来像我上面假设的那样（并且您没有确认/确认...），您可以根据需要使用下一个函数来转换它：

Function convertUSStr_DateToUK(arr As Variant) As Variant
    Dim arrConv, arrStrD, i As Long
    ReDim arrConv(1 To UBound(arr), 1 To 1)
    For i = 1 To UBound(arrConv)
        If IsNumeric(arr(i, 1)) Then
            arrConv(i, 1) = DateSerial(Year(arr(i, 1)), Day(arr(i, 1)), Month(arr(i, 1)))
        Else
            arrStrD = Split(arr(i, 1), "/")
            arrConv(i, 1) = DateSerial(CLng(arrStrD(2)), CLng(arrStrD(0)), CLng(arrStrD(1)))
        End If
    Next i
    convertUSStr_DateToUK = arrConv
End Function

您可以通过以下方式使用它：

Private Sub testConvertUSStr_DateToUK()
     Dim sh As Worksheet, lastR As Long, arrD
     Const col As String = "B" 'use here your column to convert its Date
     
     Set sh = ActiveSheet
     lastR = sh.Range(col & sh.rows.count).End(xlUp).row
     
     arrD = sh.Range(col & 2 & ":" & col & lastR).Value2 'Date is taken as number...
     arrD = convertUSStr_DateToUK(arrD)
     'drop the converted array content and format it appropriately:
     With sh.cells(2, col).Offset(, 1).Resize(UBound(arrD), 1)
            .Value2 = arrD
            .NumberFormat = "dd/mm/yyyy"
     End With
End Sub

Answer 2

我也有同样的问题。感谢 FaneDuru 的回答。然而，我发现我需要进行以下代码调整（我无法将其作为评论提供，因为我没有足够的声誉）。我并不是想声称这是一个不同的答案。 我的调整可能不太优雅，可以做得更好，因为我对 VBA 还很陌生，但代码现在适用于我的情况，其中我粘贴从浏览器显示的表格（具有英国格式日期）复制的数据，并发现 Excel 是按照上面提到的 FaneDuru 处理日期。也就是说，当日期值 >12 时，将日期粘贴为 Text 不变，但当日期值为 <=12 the text is converted to a Date format assuming that the source text is a US format date (regardless of Windows localisation settings).

时

我更改了函数中的第二个 DateSerial() 调用（即，单元格内容被检测为不是通用文本格式的数字的 Else 情况），因为答案中调用中使用的顺序（我认为）是美国格式日期。 OP 指定他们的源日期（文本）均为英国格式（我的情况也是如此）。

Function convertUSStr_DateToUK(arr As Variant) As Variant
    Dim arrConv, arrStrD, i As Long
    ReDim arrConv(1 To UBound(arr), 1 To 1)
    For i = 1 To UBound(arrConv)
        If IsNumeric(arr(i, 1)) Then
            arrConv(i, 1) = DateSerial(Year(arr(i, 1)), Day(arr(i, 1)), Month(arr(i, 1)))
        Else
            arrStrD = Split(arr(i, 1), "/")
            arrConv(i, 1) = DateSerial(CLng(arrStrD(2)), CLng(arrStrD(1)), CLng(arrStrD(0)))
        End If
    Next i
    convertUSStr_DateToUK = arrConv  
End Function

我还更改了子例程中的“With sh.Cells(2, col).Offset(, 0).Resize(UBound(arrD), 1)”行，以便 Offset 为 (,0) 而不是 (,1 ），因为我发现在原始代码中，更正后的值被粘贴到下一列中（这可能是故意的）。此调整是为了使最终输出仅就地纠正日期。

    Private Sub testConvertUSStr_DateToUK()
     Dim sh As Worksheet, lastR As Long, arrD
     Const col As String = "D" 'use here your column to convert its Date
     
     Set sh = ActiveSheet
     lastR = sh.Range(col & sh.Rows.Count).End(xlUp).Row
     
     arrD = sh.Range(col & 2 & ":" & col & lastR).Value2 'Date is taken as number...
     arrD = convertUSStr_DateToUK(arrD)
     'drop the converted array content and format it appropriately:
     With sh.Cells(2, col).Offset(, 0).Resize(UBound(arrD), 1)
            .Value2 = arrD
            .NumberFormat = "dd/mm/yyyy"
     End With
End Sub