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

Question

我有一个单元格，它包含所有的历史更新，每个更新都会显示一个日期/时间戳，然后在他们的笔记之前显示用户的名字。我需要提取所有的日期/时间/名称印章，以汇总它们的出现情况。+EDIT+，我需要从每个邮票中获取名称和日期部分，这样我就能够在枢轴表中绘制信息。"3/3/2016瑞秋·博耶斯；3/2/2016瑞秋·博耶斯；3/2/2016詹姆斯·多蒂“

例："3/3/2016 9:28:36上午瑞秋·博耶斯： EEHAW！泰瑞回答！你好，瑞秋，我找不到匹配使用4232 A或12319零件编号。3/2/2016 7:39:06上午瑞秋·博耶斯：将EM发送给Terri每个EM回复。3/2/2016 7:35:06上午，詹姆斯·多蒂： 2/29/16向金姆发送了另一个EM。收到自动回复如下:谢谢您的邮件。金12/7/2015 12:26:25下午12:25弗兰克德拉托雷：再次VM -把傅推到假期之后。

Answer 1

基于添加信息的编辑

编辑(5/16/2016)：我对代码做了一些修改，如下所示。一个基于新信息的更改允许您将JoinArrayWithSemiColons函数用作标准工作表函数或模块中使用的函数。那么，这意味着什么？这意味着(假设要解析的单元格是A1)，在单元格B1中，您可以编写类似于=JoinArrayWithSemiColons(A1)的函数，就像编写普通工作表函数一样。但是，如果您仍然希望使用VBA在一系列单元格上执行此操作，则可以运行类似于TestFunction()的过程，如下所示。另外，请注意，ExtractDateTimeUsers函数不一定需要用户直接调用，因为它现在被专门用作JoinArray...函数的辅助函数。

如果这能帮我把事情弄清楚，请告诉我。

旧邮政

您可以使用一些正则表达式来完成这一任务。有关示例，请参阅下面的代码。在我的例子中，我有一个函数来返回多维的结果数组。在我的测试过程中，我调用这个函数，然后将结果分配给一个空的单元格矩阵(在您的测试用例中，您必须确定将它放在哪里)。您不必将结果分配给一组单元格，而是可以对数组做任何您想做的事情。

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

Answer 2

作为简单的(非正则表达式)函数，您可以使用以下内容：

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

只需将其放在一个模块中，将其用作UDF。(输出3列表)

如果你有任何问题，只需问:)

Answer 3

只是另一种方法。也许有点慢，但又短又易读.

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