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

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

---

2016年8月11日变更gggqqq2i8yj，2016年9月29日删除，2016年9月30日增加，MKDJEN200 03OCT2016 zzxxddd4423 04OCT2016 jioi==+-234JJJU 2016年10月24日更新tuiomahdkj 2017年1月10日更新ZZZT4123III 2017年1月13日更新JUKALZZ1232017年1月20日IIIWWAAZZ678UUUH

数据位于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

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

如果日期是唯一的“数字”，则可以使用

SpecialCells（）

如果字符串位于单元格“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

---

下面的方法保留了字符串格式，即日期写为字符串（它使用一个简单的正则表达式）。 假设：字符串写在单元格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

请尝试下面的代码

添加了一些错误处理，以防通过

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

选项显式
分日期（）
Dim Reg1作为对象
Dim RegMatches作为变量
作为变体的暗淡匹配
我想我会坚持多久
迟钝的
暗淡如长
将dMon设置为字符串
Set Reg1=CreateObject（“VBScript.RegExp”）
使用Reg1
.Global=True
.IgnoreCase=True
.Pattern=“（\d{2}[a-zA-Z]{3}\d{4}）”匹配由2个数字组成的任意一组3个字母和4个数字
以
Set RegMatches=Reg1.Execute（范围（“A1”）.Value）
i=1
如果RegMatches.Count>=1，则
对于RegMatches中的每个匹配
dDay=左（匹配，2）
dYear=Mid（匹配，6,4）
dMon=Mid（匹配，3，3）
出错时继续下一步
如果不是IsError（日期值（dDay&“-”&dMon&“-”&dYear）），则
如果错误号为0，则
其他的
范围（“B”和i）。值=（匹配）
Range（“C”&i）.Value=DateValue（dDay&“-”&dMon&“-”&dYear）”使用VBA的函数
Mid（）
。@user7078484它是一个长
字符串吗？还是几个？（如Paul编辑的）这是一个长字符串日期是否始终采用DDMMMYYYY格式？您应该使用正则表达式。您应该补充，只有当日期被空格“包围”时，这才有效。是的，理解，但问题是如果数据总是这样，OP需要回答哪一个问题谢谢，Gary的学生@Storax，是的，日期被空格包围。
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