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

Question

我有一个包含所有历史更新的单元格，每个更新都显示日期/时间戳，然后在注释前显示用户名。我需要提取所有的日期/时间/名称戳来汇总它们的出现次数。 +EDIT+ 我需要从每个邮票中获取名称和日期部分，以便能够在数据透视表中绘制信息。 类似的输出； “2016 年 3 月 3 日雷切尔博耶斯；2016 年 3 月 2 日雷切尔博耶斯；2016 年 3 月 2 日詹姆斯多蒂”

前： “2016 年 3 月 3 日上午 9:28:36 Rachel Boyers： EEHAW！Terri 回复了！！！你好 Rachel， 我找不到使用 4232A 或 12319 部件号的匹配项。 2016 年 3 月 2 日上午 7:39:06 Rachel Boyers：根据 EM 回复将 EM 发送给 Terri - Eng。 2016 年 3 月 2 日上午 7:35:06 James Dorty： 2/29/16 向 Kim 发送了另一个 EM。收到的自动回复如下：感谢您的邮件。 Kim 2015 年 12 月 7 日下午 12:26:25 Frank De La Torre： 再次 VM - 将 FU 推出直到假期结束。

Answer 1

根据补充信息编辑

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

让我知道这是否有助于澄清一些事情。

旧帖

您可以使用一些正则表达式来完成此操作。有关示例，请参见下面的代码。就我而言，我有一个函数可以返回一个多维结果数组。在我的测试过程中，我调用此函数，然后将结果分配给单元格的 EMPTY 矩阵（在您的测试用例中，您必须确定将其放置在何处）。您不必将结果分配给一组单元格，而是可以对数组做任何您想做的事情。

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