试图在excel小瓶vba中将iso 8601日期时间转换为实际日期时间

Question

我发现如何通过公式转换这个2020-10-06T16:19:00：

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

但我正在尝试通过 VBA 将其应用到整个列中。这是VBA Examples

我试过这个：

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

---

更强大的正则表达式功能，可以转换所有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