问从单个单元格中提取多个日期

EN

Private Function ExtractDateTimeUsers(nInput As String) As Variant()
    Dim oReg As Object
    Dim aOutput() As Variant
    Dim nMatchCount As Integer
    Dim i As Integer
    Dim vMatches As Object

    Set oReg = CreateObject("VBScript.RegExp")

    With oReg
        .MultiLine = False
        .Global = True
        .Pattern = "([0-9]{1,2}/[0-9]{1,2}/[0-9]{2,4}) ([0-9]{1,2}:[0-9]{1,2}:[0-9]{1,2} [AP]M) (.*?):"
    End With

    If oReg.Test(nInput) Then
        Set vMatches = oReg.Execute(nInput)
        nMatchCount = vMatches.Count
        ReDim aOutput(0 To nMatchCount - 1, 0 To 2)

        For i = 0 To nMatchCount - 1
            aOutput(i, 0) = vMatches(i).Submatches(0)
            aOutput(i, 1) = vMatches(i).Submatches(1)
            aOutput(i, 2) = vMatches(i).Submatches(2)
        Next i
    Else
        ReDim aOutput(0 To 0, 0 To 0)
        aOutput(0, 0) = "No Matches"
    End If


    ExtractDateTimeUsers = aOutput
End Function

Function JoinArrayWithSemiColons(sInput As String) As String
    Dim vArr As Variant

    vArr = ExtractDateTimeUsers(sInput)

    If vArr(0, 0) = "No Matches" Then
        JoinArrayWithSemiColons = "No Matches"
        Exit Function
    End If

    'Loop through array to build the output string
    For i = LBound(vArr, 1) To UBound(vArr, 1)
        sOutput = sOutput & "; " & vArr(i, 0) & " " & vArr(i, 2)
    Next i

    JoinArrayWithSemiColons = Mid(sOutput, 3)
End Function

Sub TestFunction()
    'Assume the string we are parsing is in Column A
    '(I defined a fixed range, but you can make it dynamic as you need)

    Dim rngToJoin As Range
    Dim rIterator As Range

    Set rngToJoin = Range("A10:A11")

    For Each rIterator In rngToJoin
        rIterator.Offset(, 1).Value = JoinArrayWithSemiColons(rIterator.Value)
    Next rIterator

End Sub

Public Function getCounts(str As String) As Variant

  Dim output() As Variant, holder As Variant, i As Long

  ReDim output(0, 0)
  holder = Split(str, " ")

  For i = 0 To UBound(holder) - 2
    If IsDate(holder(i) & " " & holder(i + 1) & " " & holder(i + 2)) Then

      If UBound(output) Then
        ReDim Preserve output(1 To 3, 1 To UBound(output, 2) + 1)
      Else
        ReDim output(1 To 3, 1 To 1)
      End If

      output(1, UBound(output, 2)) = holder(i)
      output(2, UBound(output, 2)) = holder(i + 1) & " " & holder(i + 2)
      i = i + 3

      While Right(holder(i), 1) <> ":" And i < UBound(holder)
        output(3, UBound(output, 2)) = output(3, UBound(output, 2)) & " " & holder(i)
        i = i + 1
      Wend

      output(3, UBound(output, 2)) = Trim(output(3, UBound(output, 2))) & " " & Left(holder(i), Len(holder(i)) - 1)

    End If
  Next

  If Application.Caller.Rows.Count > UBound(output, 2) Then
    i = UBound(output, 2)
    ReDim Preserve output(1 To 3, 1 To Application.Caller.Rows.Count)

    For i = i + 1 To UBound(output, 2)
      output(1, i) = ""
      output(2, i) = ""
      output(3, i) = ""
    Next

  End If

  getCounts = Application.Transpose(output)

End Function

Public Function DateCount(str As String) As Variant
Dim pos As Integer, endpos As Integer, namepos As Integer
Dim Text As String, Output() As String, counter As Integer
    pos = InStr(pos + 1, str, "/")
    Do While pos > 0
        endpos = InStr(pos + 1, str, "M ")
        Text = Mid(str, pos - 1, endpos - pos + 2)
        If IsDate(Text) Then
            counter = counter + 1
            ReDim Preserve Output(1 To 2, 1 To counter)
            namepos = InStr(endpos, str, ":")
            Output(1, counter) = Text
            Output(2, counter) = Mid(str, endpos + 2, namepos - endpos - 2)
            pos = namepos
        End If
        pos = InStr(pos + 1, str, "/")
    Loop

' Only Count
getCounts = counter
' complete List
getCounts = Output
End Function