不同格式的VBA粘贴数组日期值

Question

我有一个简单的宏，其中包含一个动态数组，可以满足条件。数据将按预期运行的方式填充宏，直到将数据粘贴到电子表格上为止。现在，除日期值外，所有数据均已正确粘贴。日期值从欧洲格式错误地粘贴到电子表格（即dd-mm-yyyy到mm-dd-yyyy）上。因此，例如，电子表格上的2019年3月1日变为2019年1月3日。请注意，无论我是否事先格式化目标文件，仍然会出现问题。

该数组有14列，只有12-13列是日期值。

编辑摘要

从无关信息中切碎代码；添加了结果图像。

以下是代码

Sub Verification()
    Dim NewWorkbook As String, NewWorksheet As String
    Dim wb As Workbook, sh As Worksheet
    Dim LoopCounter As Long
    Dim NewEntryCounter As Long
    Dim Cols As Long, Rows As Long
    Dim r As Range
    Dim arr As Variant, NewEntry() As Variant
    Dim myRange As Integer

    NewWorkbook = LCase(InputBox("What is the name of the new report?"))
    NewWorksheet = LCase(InputBox("What is the name of the sheet?"))
    Set wb = ThisWorkbook
    Set sh = wb.Sheets("Renouvellement")

        Cols = Workbooks(NewWorkbook).Sheets(NewWorksheet).Range(Workbooks(NewWorkbook).Sheets(NewWorksheet).Cells(1, 1), Workbooks(NewWorkbook).Sheets(NewWorksheet).Cells(1, 1).End(xlToRight)).Count
        Rows = sh.Range(sh.Cells(1, 1), sh.Cells(1, 1).End(xlDown)).Count

        For Each r In Workbooks(NewWorkbook).Sheets(NewWorksheet).Range("A2", Workbooks(NewWorkbook).Sheets(NewWorksheet).Range("A1").End(xlDown))
        If (r.Offset(0, 21).Text = "Red" Or r.Offset(0, 21).Text = "Blue") And r.Offset(0, 17).Value >= 24 Then
            arr = Application.VLookup(r.Value, sh.Range("A:A"), 1, 0)

            If IsError(arr) Then
                NewEntryCounter = NewEntryCounter + 1
                ReDim Preserve NewEntry(1 To Cols, 1 To NewEntryCounter)
                For LoopCounter = 1 To Cols
                    NewEntry(LoopCounter, NewEntryCounter) = r.Offset(0, LoopCounter - 1)
                Next LoopCounter
            Else

End Sub

在“本地”窗口中抽样结果

将日期值传输到电子表格时的采样结果

如您所见，将数据从vba传输到电子表格时，插入的第一个值已更改。第二个值已正确传输。第三个不是，依此类推。

Answer 1

同样，我很难确切地了解您在做什么，但就复制相关数据而言，似乎筛选器可能更简单。

在您的代码中，您将多次调用工作表，并对VBA阵列进行了多个Redim Preserve操作。这些操作可能会很昂贵。

也许可以用（例如，显然，您可能需要更改工作表和范围变量）来简化（并加速）部分代码：

Set ws = Worksheets("sheet1")
Set r = ws.Range("a1").CurrentRegion
With r
    .AutoFilter field:=22, Criteria1:="red", Operator:=xlOr, Criteria2:="blue"
    .AutoFilter field:=18, Criteria1:=">=24"
End With

r.SpecialCells(xlCellTypeVisible).Copy

'Paste somewhere

ws.ShowAllData