如何用宏查找、替换文本样式

[s777n]

达人们好，刚刚接触vba

请教一下，如何创建一个宏？
来实现这样一个功能：
对这样的一个文本

word中已经新建了2个格式 日期格式 和 标题格式
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
(2008-10-10)
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
(2008-10-20)
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

用正则查找到(xxxx-x-x)的日期，然后把他的格式改变为 日期格式。 并且把日期之上的一行也改变为 标题格式。

可以用宏实现吗，谢谢！
希望不吝赐教.

[gengzhw]

这个版块关注度就是差，这个帖子只有楼主自己在整，顶一下

[zhiyongtu]

Sub FindAndApply()
    Const StrPattern As String = "\d\d\d\d-[01]\d-[0-3]\d"
    Const MyStyleDate As String = "我的日期样式", MyStyleHeading As String = "我的标题样式"
    Dim rngToSearch As Range, reRegExp As Object, oMatches As Object
    Dim lStart As Long, lEnd As Long, lCount As Long, lTmp As Long
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst, Count:=1
    Set rngToSearch = Selection.Range
    rngToSearch.MoveEnd wdStory, 1
    Set reRegExp = CreateObject("VBScript.RegExp")
    lCount = 0
    Do While (1)
        reRegExp.Global = False
        reRegExp.IgnoreCase = True
        reRegExp.MultiLine = False
        reRegExp.Pattern = StrPattern
        Set oMatches = reRegExp.Execute(rngToSearch.Text)
        If oMatches.Count = 0 Then Exit Do
        lStart = rngToSearch.Start + oMatches(0).FirstIndex
        lEnd = lStart + oMatches(0).Length
        ThisDocument.Range(Start:=lStart, End:=lEnd).Select
        Selection.Style = ThisDocument.Styles(MyStyleDate)
        Selection.HomeKey Unit:=wdLine, Extend:=wdMove
        lTmp = Selection.Start
        Selection.GoTo What:=wdGoToLine, Which:=wdGoToPrevious, Count:=1
        Selection.EndKey Unit:=wdLine, Extend:=wdExtend
        If Selection.Start < lTmp Then Selection.Style = ThisDocument.Styles(MyStyleHeading)
        lCount = lCount + 1
        Set rngToSearch = ThisDocument.Range(Start:=lEnd, End:=ThisDocument.Content.End)
    Loop
    MsgBox "共匹配了" & lCount & "次。已应用“" & MyStyleDate & "”和“" & MyStyleHeading & "”样式。", , "匹配结果"
    Set rngToSearch = Nothing
    Set reRegExp = Nothing
    Set oMatches = Nothing
End Sub

以下声明根据实际需要设置：

    Const MyStyleDate As String = "我的日期样式", MyStyleHeading As String = "我的标题样式"

[s777n]

木有人吗

[s777n]

搞出来了一半了
实现了，循环找到(日期)并且把它的样式设置为日期格式，但如何得到 日期上面一行呢，期待达人

    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "(\([0-9]{4}-[0-9]{2}-[0-9]{2}\))"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Do While Selection.Find.Execute
    Selection.Style = ActiveDocument.Styles("日期格式")
    Loop
    
End Sub

[s777n]

Sub SetStyle()

    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "(\([0-9]{4}-[0-9]{2}-[0-9]{2}\))"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Do While Selection.Find.Execute
        Selection.Style = ActiveDocument.Styles("日期格式")
        Selection.MoveUp Unit:=wdLine, Count:=1
        Selection.Style = ActiveDocument.Styles("标题格式")
        Selection.MoveDown Unit:=wdLine, Count:=1
        Selection.MoveDown Unit:=wdLine, Count:=1
    Loop
    
End Sub

不知道有没有更好的解决方法，暂时解决了。

结贴