VBA вставляет значения даты в массиве в другом формате

Question

У меня есть простой макрос, который включает в себя динамический массив, который заполняется при соблюдении условий.Данные заполняют макрос так, как он должен функционировать, пока он не вставит данные в электронную таблицу.Теперь все данные вставлены правильно, за исключением значений даты.Значения даты ошибочно вставляются из таблицы в европейский формат в американский (например, дд-мм-гггг в мм-дд-гггг).Так, например, 1 марта 2019 года становится 3 января 2019 года в электронной таблице.Обратите внимание, что либо я предварительно форматирую файлы назначения, либо нет, проблема все еще возникает.

Массив имеет 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

Опять же, мне немного сложно понять, что именно вы делаете, но кажется, что фильтр может быть проще, если речь идет о копировании соответствующих данных.

В вашем коде вы выполняете несколько вызовов рабочей таблицы и несколько Redim Preserve операций над массивом VBA. Эти операции могут быть дорогостоящими.

Возможно, эту часть кода можно упростить (и ускорить) с помощью чего-то вроде (очевидно, вам может потребоваться изменить таблицу и переменные диапазона):

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