以下程序是VBA多表汇总程序，单表中日期格式是2018/10/12  3:17:51,   VBA汇总后日期变为10/12/2018  3:17:51 PM，请问是程序哪里出了问题，怎么改才能保证日期不变?

Sub Collectwk()
    'ExcelHome VBA编程学习与实践
    Dim Trow&, k&, arr, brr, i&, j&, book&, a&
    Dim p$, f$, Rng As Range
    With Application.FileDialog(msoFileDialogFolderPicker)
    '取得用户选择的文件夹路径
        .AllowMultiSelect = False
        If .Show Then p = .SelectedItems(1) Else Exit Sub
    End With
    If Right(p, 1) <> "\" Then p = p & "\"
    '
    Trow = Val(InputBox("请输入标题的行数", "提醒"))
    If Trow < 0 Then MsgBox "标题行数不能为负数。", 64, "警告": Exit Sub
    Application.ScreenUpdating = False '关闭屏幕更新
    Cells.ClearContents '清空当前表数据
    ReDim brr(1 To 200000, 1 To 1)
    '定义装汇总结果的数组brr，最大行数为20万行
    f = Dir(p & "*.xls*")
    '开始遍历指定文件夹路径下的每个工作簿
    Do While f <> ""
        If f <> ThisWorkbook.Name Then '避免同名文件重复打开出错
            With GetObject(p & f)
            '以\'只读\'形式读取文件时，使用getobject方法会比workbooks.open稍快
                Set Rng = .Sheets(1).UsedRange
                If IsEmpty(Rng) = False Then '如果工作表非空
                    book = book + 1 '标记一下是否首个Sheet,如果首个sheet，BOOK=1
                    a = IIf(book = 1, 1, Trow + 1) '遍历读取arr数组时是否扣掉标题行
                    arr = Rng.Value '数据区域读入数组arr
                    If UBound(arr, 2) > UBound(brr, 2) Then
                    '动态调整结果数组brr的最大列数，避免明细表列数不一的情况。
                        ReDim Preserve brr(1 To 200000, 1 To UBound(arr, 2))
                    End If
                    For i = a To UBound(arr) '遍历行
                        k = k + 1 '累加记录条数
                        For j = 1 To UBound(brr, 2) '遍历列
                            brr(k, j) = arr(i, j)
                        Next
                    Next
                End If
                .Close False '关闭工作簿，不保存。
            End With
        End If
        f = Dir '下一个工作簿
    Loop
    If k > 0 Then
        [a1].Resize(k, UBound(brr, 2)) = brr
        MsgBox "汇总完成。"
    End If
    Application.ScreenUpdating = True '恢复屏幕更新
End Sub