嘗試在excel小瓶vba中將iso 8601日期時間轉換為實時日期時間

Question

我發現如何通過公式轉換這個2020-10-06T16:19:00是：

=DATEVALUE(MID(A1,1,10))+TIMEVALUE(MID(A1,12,8))

但我試圖通過 VBA 來做到這一點，以將其應用於整列。 這是VBA 示例

我試過這個：

Public Function UTCToLocalTime(dteTime As Date) As Date
  Dim infile As FILETIME
  Dim outfile As FILETIME
  Dim insys As SYSTEMTIME
  Dim outsys As SYSTEMTIME

  insys.wYear = CInt(Year(dteTime))
  insys.wMonth = CInt(Month(dteTime))
  insys.wDay = CInt(Day(dteTime))
  insys.wHour = CInt(Hour(dteTime))
  insys.wMinute = CInt(Minute(dteTime))
  insys.wSecond = CInt(Second(dteTime))

  Call SystemTimeToFileTime(insys, infile)
  Call FileTimeToLocalFileTime(infile, outfile)
  Call FileTimeToSystemTime(outfile, outsys)

  UTCToLocalTime = CDate(outsys.wDay & "/" & _
    outsys.wMonth & "/" & _
    outsys.wYear & " " & _
    outsys.wHour & ":" & _
    outsys.wMinute & ":" & _
    outsys.wSecond)
  End Function

但收到一個錯誤：您的幫助將不勝感激。

Sub ChangeFormat()

Dim sh As Worksheet
Dim Tuming As String
Dim LastRow As Long

Set ws = Sheet43
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
ws.Range("C2:C" & LastRow).NumberFormat = "m/d/yyyy h:mm"

Tuming = "2020-10-06T16:19:00"

Debug.Print UTCToLocalTime(Tuming)

End Sub

Answer 1

最安全的方法是將字符串分成幾部分，然后使用DateSerial和TimeSerial方法將其組合在一起。

Option Explicit

Public Sub example()
    Range("A1").Value = ConvertISO8601StringToDate("2020-10-06T16:19:00")
    Range("A1").NumberFormat = "m/d/yyyy h:mm"
End Sub

Public Function ConvertISO8601StringToDate(ByVal InputString As String) As Date
    
    Dim DatePart As Date
    DatePart = DateSerial(Left$(InputString, 4), Mid$(InputString, 6, 2), Mid$(InputString, 9, 2))
    
    Dim TimePart As Date
    TimePart = TimeSerial(Mid$(InputString, 12, 2), Mid$(InputString, 15, 2), Mid$(InputString, 18, 2))
    
    
    ConvertISO8601StringToDate = DatePart + TimePart
End Function

要轉換整個范圍，請使用數組進行快速處理：

Public Sub ConvertRange()
    Dim RangeToConvert As Range  ' define range
    Set RangeToConvert = ThisWorkbook.Worksheets("Sheet1").Range("A1:A13")
    
    Dim DataArray() As Variant  ' convert range into array for fast processing
    DataArray = RangeToConvert.Value
    
    ' loop throug array data
    Dim iRow As Long
    For iRow = LBound(DataArray, 1) To UBound(DataArray, 1)
        Dim iCol As Long
        For iCol = LBound(DataArray, 2) To UBound(DataArray, 2)
            
            ' convert iso8601 conform strings and leave the rest unchanged
            Dim DateVal As Date
            On Error Resume Next
                DateVal = ConvertISO8601StringToDate(DataArray(iRow, iCol))
                If Err.Number = 0 Then  ' only convert iso8601 strings
                    DataArray(iRow, iCol) = DateVal
                End If
            On Error GoTo 0
        Next iCol
    Next iRow
    
    ' write array data back to sheet
    RangeToConvert.Value = DataArray
End Sub

---

更強大的 RegEx 功能，可以轉換所有 ISO8601 定義的格式：

時區時間的輸出轉換為 UTC+00:00。 因此，如果需要在任何其他區域中，則需要在此之后進行轉換。 例如進入通勤者時區。

對於沒有指定日期（如YYYY 、 YYYY-MM或YYYY-Www的日期，始終假定該時間段的第一天。 因此，例如2004-W28將該周的開始日期設為2004-07-05以獲得該周的結束時間，您只需在開始處添加+6 。 此外， 2004-07將假定為2004-07-01月初。 並且年份2004將轉換為日期2004-01-01 。

Public Function ConvDateTime(ByVal InVal As String) As Date
    Dim SplitDateTime() As String
    SplitDateTime = Split(InVal, "T")
    
    ConvDateTime = ConvDate(SplitDateTime(0)) + ConvTime(SplitDateTime(1))
End Function

Public Function ConvDate(ByVal InVal As String) As Date
    Dim RetVal As Variant
    
    Dim RegEx As Object
    Set RegEx = CreateObject("VBScript.RegExp")
    
    With RegEx
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
    End With
    
    RegEx.Pattern = "^(\d{4})-?(\d{2})?-?(\d{2})?$|^(\d{4})-?W(\d{2})?-?(\d)?$|^(\d{4})-?(\d{3})$"
    Dim Match As Object
    Set Match = RegEx.Execute(InVal)
    
    If Match.Count <> 1 Then Exit Function
    With Match(0)
        If Not IsEmpty(.SubMatches(0)) Then
            'YYYY-MM-DD
            If IsEmpty(.SubMatches(1)) Then  'YYYY
                RetVal = DateSerial(CInt(.SubMatches(0)), 1, 1)
            ElseIf IsEmpty(.SubMatches(2)) Then 'YYYY-MM
                RetVal = DateSerial(CInt(.SubMatches(0)), CInt(.SubMatches(1)), 1)
            Else 'YYYY-MM-DD
                RetVal = DateSerial(CInt(.SubMatches(0)), CInt(.SubMatches(1)), CInt(.SubMatches(2)))
            End If
        ElseIf Not IsEmpty(.SubMatches(3)) Then
            'YYYY-Www-D
            RetVal = DateSerial(CInt(.SubMatches(3)), 1, 4) '4th of jan is always week 1
            RetVal = RetVal - Weekday(RetVal, 2) 'subtract the weekday number of 4th of jan
            RetVal = RetVal + 7 * (CInt(.SubMatches(4)) - 1) 'add 7 times the (weeknumber - 1)
            
            If IsEmpty(.SubMatches(5)) Then 'YYYY-Www
                RetVal = RetVal + 1 'choose monday of that week
            Else 'YYYY-Www-D
                RetVal = RetVal + CInt(.SubMatches(5)) 'choose day of that week 1-7 monday to sunday
            End If
        Else
            'YYYY-DDD
            RetVal = DateSerial(CInt(.SubMatches(6)), 1, 1) + CInt(.SubMatches(7)) - 1
        End If
    End With
    
    ConvDate = RetVal
End Function

Public Function ConvTime(ByVal InVal As String) As Date
    Dim RetVal As Variant
    
    Dim RegEx As Object
    Set RegEx = CreateObject("VBScript.RegExp")
    
    With RegEx
        .Global = True
        .MultiLine = False
        .IgnoreCase = False
    End With
    
    RegEx.Pattern = "^(\d{2}):?(\d{2})?:?(\d{2})?(\+|\-|Z)?(\d{2})?:?(\d{2})?$|^(\d{2}):(\d{2}):(\d{2}\.?\,?\d{4})?(\+|\-|Z)?(\d{2})?:?(\d{2})?$"
    Dim Match As Object
    Set Match = RegEx.Execute(InVal)
    
    If Match.Count <> 1 Then Exit Function
    With Match(0)
        If Not IsEmpty(.SubMatches(0)) Then
            'hh:mm:ss
            If IsEmpty(.SubMatches(1)) Then  'hh
                RetVal = TimeSerial(CInt(.SubMatches(0)), 0, 0)
            ElseIf IsEmpty(.SubMatches(2)) Then  'hh:mm
                RetVal = TimeSerial(CInt(.SubMatches(0)), CInt(.SubMatches(1)), 0)
            Else 'hh:mm:ss
                RetVal = TimeSerial(CInt(.SubMatches(0)), CInt(.SubMatches(1)), CInt(.SubMatches(2)))
            End If
            
            If Not IsEmpty(.SubMatches(3)) Then
                If Not .SubMatches(3) = "Z" Then
                    If Not IsEmpty(.SubMatches(4)) Then
                        RetVal = DateAdd("h", -1& * CDbl(.SubMatches(3) & .SubMatches(4)), RetVal)
                    End If
                    If Not IsEmpty(.SubMatches(5)) Then
                        RetVal = DateAdd("n", -1& * CDbl(.SubMatches(3) & .SubMatches(5)), RetVal)
                    End If
                End If
            End If
            
        Else
            'hh:mm:ss,f
            Dim Milliseconds As String
            Milliseconds = .SubMatches(8)
            Milliseconds = Replace$(Milliseconds, ",", Application.DecimalSeparator)
            Milliseconds = Replace$(Milliseconds, ".", Application.DecimalSeparator)
            
            RetVal = TimeSerial(CInt(.SubMatches(6)), CInt(.SubMatches(7)), 0)
            RetVal = RetVal + (CDbl(Milliseconds) / 60 / 60 / 24) ' TimeSerial does not support milliseconds
        End If
    End With
    
    ConvTime = RetVal
End Function