VBA：如何从字符串中仅保留日期值？

Question

我有以下字符串，并想知道如何从中提取日期值并将它们存储在单独的单元格中。

11AUG2016 现已更改gggqqq2i8yj 29SEP2016 已删除tyijdg298 30SEP2016 已添加，mkdjenb200 03OCT2016 zzxxddd4423 04OCT2016 jioi==++-234jju 24OCT2016 已更新tuiomahdkj 10JAN2017 已更新zzzz T4123III 13JAN2017 已更新jukalzzz123 20JAN2017 iiiwwwaazz678uuh

- user7078484

---

使用VBA的Mid()函数。 - Paul Ogilvie

@user7078484 这是一个长的 String 吗？还是几个短的？（例如由 Paul 编辑） - Shai Rado

这是一个长字符串。 - user7078484

日期格式总是<空格>DDMMMYYYY<空格>吗？ - Storax

你应该使用正则表达式。 - Shai Rado

Answer 1

使用A1中的数据，尝试执行以下操作：

Sub marine()
    Dim s As String, r As Range
    s = Range("A1").Value
    ary = Split(s, " ")
    i = 2
    For Each a In ary
            Cells(i, 1).Value = a
            If IsDate(Cells(i, 1).Value) Then
                i = i + 1
            End If
    Next a

    Set r = Cells(Rows.Count, 1).End(xlUp)
    If IsDate(r.Value) Then Exit Sub
    r.Clear
End Sub

该技术将一个候选项放入单元格中，然后测试它是否为日期。如果是日期，则保留，否则覆盖。

- Gary's Student

---

你应该添加说明，仅当日期被“空格”包围时才有效。 - Storax

是的，我明白了，但问题是如果数据始终如此，那么原帖作者需要回答哪个问题。 - Storax

谢谢，Gary的学生！！ - user7078484

@Storax，是的，日期被空格包围着。 - user7078484

Answer 2

如果日期是唯一的“数字”，那么您可以使用SpecialCells()。

Sub main()
    Dim arr As Variant

    arr = Split("11AUG2016 Changed gggqqq2i8yj 29SEP2016 Removed tyijdg298 30SEP2016 Added ,mkdjenb200 03OCT2016 zzxxddd4423 04OCT2016 jioi==++-234jju 24OCT2016 Updated tuiomahdkj 10JAN2017 Updated zzzz T4123III 13JAN2017 Updated jukalzzz123 20JAN2017 iiiwwwaazz678uuh", " ")
    With Range("A1").Resize(UBound(arr) + 1)
        .Value = Application.Transpose(arr)
        .SpecialCells(xlCellTypeConstants, xlTextValues).Delete xlUp
    End With
End Sub

如果字符串在单元格"A1"中，代码如下：

Sub main()
    Dim arr As Variant

    With Range("A1")
        arr = Split(.Value, " ")
        With .Resize(UBound(arr) + 1)
            .Value = Application.Transpose(arr)
            .SpecialCells(xlCellTypeConstants, xlTextValues).Delete xlUp
        End With
    End With
End Sub

- user3598756

Answer 3

以下方法保留字符串格式，即日期以字符串形式书写（它使用简单的正则表达式）。 假设：您的字符串写在单元格A1中。

Sub ExtractDateFromString()
    Dim s As String: s = Range("A1")
    Dim re As Object: Set re = CreateObject("VBScript.RegExp")
    re.Global = True
    re.Pattern = "(\d{2}[A-Z]{3}20\d{2}\s)"
    Set d = re.Execute(s)
    r = 2
    For Each x In d
        Range("A" & r) = x
        r = r + 1
    Next
End Sub

- Eddie Kumar

Answer 4

请尝试以下代码。

添加了一些错误处理，以防RegEx通过，但其中的值不是有效日期。

Option Explicit

Sub ExtractDates()

Dim Reg1 As Object
Dim RegMatches As Variant
Dim Match As Variant
Dim i As Long

Dim dDay As Long
Dim dYear As Long
Dim dMon As String

Set Reg1 = CreateObject("VBScript.RegExp")
With Reg1
    .Global = True
    .IgnoreCase = True
    .Pattern = "(\d{2}[a-zA-Z]{3}\d{4})" ' Match any set of 2 digits 3 alpha and 4 digits
End With

Set RegMatches = Reg1.Execute(Range("A1").Value)

i = 1
If RegMatches.Count >= 1 Then
    For Each Match In RegMatches
        dDay = Left(Match, 2)
        dYear = Mid(Match, 6, 4)
        dMon = Mid(Match, 3, 3)

        On Error Resume Next
        If Not IsError(DateValue(dDay & "-" & dMon & "-" & dYear)) Then
            If Err.Number <> 0 Then
            Else
                Range("B" & i).Value = (Match)
                Range("C" & i).Value = DateValue(dDay & "-" & dMon & "-" & dYear) ' <-- have the date (as date format) in column C
                i = i + 1
            End If
        End If
        On Error GoTo 0
    Next Match
End If

End Sub

- Shai Rado