VBA：我如何只保留一个string的date值？
我有一个下面的string，想知道如何从中提取date值并将它们存储在单独的单元格中。
11AUG2016更改了gggqqq2i8yj 29SEP2016删除了tyijdg298 30SEP2016已添加，mkdjenb200 03OCT2016 zzxxddd4423 04OCT2016 jioi == ++ – 234jju 24OCT2016更新了tuiomahdkj 10JAN2017更新了zzzz T4123III 13JAN2017更新了jukalzzz123 20JAN2017 iiiwwwaazz678uuh
用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
该技术将候选人放置在一个单元格中，然后testing它是否是一个date。 如果是date，则保留，否则将被覆盖。
如果date是唯一的“数字”，那么你可以使用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
如果string在单元格“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
以下方法保留string格式 – 即date被写为string（它使用简单的正则expression式）。 假设：你的string写在单元格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}[AZ]{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
尝试下面的代码。
增加了一些error handling，以防止RegEx通过，但里面的值不是一个有效的date。
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