求助vba如何让每一个含【解析】关键词的段落前缀它相对前一个段落的段首数字字符

youxianwei

求助vba如何让每一个含【解析】关键词的段落前缀它相对前一个段落的段首数字字符？

ssfx1982

1. 不懂WORD的VBA,学着写个供你参考。
   
2. Sub test()
   
3.     Dim regx, brr(), str1$, str2$, i&, k&
   
4.     str1 = "^█\d+\.": str2 = "^【解析】"
   
5.     Set regx = CreateObject("VBScript.Regexp")
   
6.     With regx
   
7.         .Pattern = str1
   
8.     End With
   
9.    
   
10.     With ActiveDocument
    
11.     For i = 1 To .Paragraphs.Count
    
12.         a = .Paragraphs(i).Range.Text
    
13.         If Len(a) Then
    
14.             If regx.test(a) Then
    
15.                 k = k + 1
    
16.                 ReDim Preserve brr(1 To k)
    
17.                 brr(k) = regx.Execute(a)(0)
    
18.             End If
    
19.         End If
    
20.     Next
    
21. 
    
22.     regx.Pattern = str2
    
23.     k = 0
    
24.     For i = 1 To .Paragraphs.Count
    
25.         a = .Paragraphs(i).Range.Text
    
26.         If Len(b) Then
    
27.             If regx.test(a) Then
    
28.                  k = k + 1
    
29.                 .Paragraphs(i).Range.Text = brr(k) & .Paragraphs(i).Range.Text
    
30.             End If
    
31.         End If
    
32.     Next
    
33.     End With
    
34.     Set regx = Nothing: Erase brr
    
35. End Sub

复制代码

youxianwei

ssfx1982 发表于 2022-12-9 16:18

感谢回答，我改正一下bug

• 不懂WORD的VBA,学着写个供你参考。
• Sub test()
•     Dim regx, brr(), str1$, str2$, i&, k&
•     str1 = "^█\d+\.": str2 = "^【解析】"
•     Set regx = CreateObject("VBScript.Regexp")
•     With regx
•         .Pattern = str1
•     End With
•     With ActiveDocument
•     For i = 1 To .Paragraphs.Count
•         a = .Paragraphs(i).Range.Text
•         If Len(a) Then
•             If regx.test(a) Then
•                 k = k + 1
•                 ReDim Preserve brr(1 To k)
•                 brr(k) = regx.Execute(a)(0)
•             End If
•         End If
•     Next
•     regx.Pattern = str2
•     k = 0
•     For i = 1 To .Paragraphs.Count
•         b = .Paragraphs(i).Range.Text    ''''''bug
•         If Len(b) Then
•             If regx.test(b) Then           ''''''bug
•                  k = k + 1
•                 .Paragraphs(i).Range.Text = brr(k) & .Paragraphs(i).Range.Text
•             End If
•         End If
•     Next
•     End With
•     Set regx = Nothing: Erase brr
• End Sub
  

lcluck2002

若不用正则，可以遍历字符串，循环查找“■”与“【解析】”，把“【解析】”替换成“■XX【解析】”。思路就是如此。代码就不替你码了。

youxianwei

ssfx1982 发表于 2022-12-9 16:18

感谢回复，我改正了下bug
Sub test()
    Dim regx, brr(), str1$, str2$, i&, k&
    str1 = "^█\d+\.": str2 = "^【解析】"
    Set regx = CreateObject("VBScript.Regexp")
    With regx
        .Pattern = str1
    End With
   
    With ActiveDocument
    For i = 1 To .Paragraphs.Count
        a = .Paragraphs(i).Range.Text
        If Len(a) Then
            If regx.test(a) Then
                k = k + 1
                ReDim Preserve brr(1 To k)
                brr(k) = regx.Execute(a)(0)
            End If
        End If
    Next

    regx.Pattern = str2
    k = 0
    For i = 1 To .Paragraphs.Count
        b = .Paragraphs(i).Range.Text      '''''''b
        If Len(b) Then                         '''''''b
            If regx.test(b) Then       '''''''b
                 k = k + 1
                .Paragraphs(i).Range.Text = brr(k) & .Paragraphs(i).Range.Text
            End If
        End If
    Next
    End With
    Set regx = Nothing: Erase brr
End Sub

youxianwei

ssfx1982 发表于 2022-12-9 16:18

您好，感谢，后面循环里的b要换成a可以运行！但如果文档中出现有题号而紧接着段无【解析】的情况运行结果数据就会出现错位。。。请问如何完善？

perfect131

这样                    

youxianwei

perfect131 发表于 2022-12-10 17:01
这样

牛逼哇！，没用vba，直接用公式！谢谢感谢！

youxianwei

问chatgpt3硬是把答案问出来了，已解决!

Sub 本单文档【解析】前缀题号vba()


            ''''''''真题集相对后段段首前缀前段题号111.【解析】
            Selection.Find.ClearFormatting
            Selection.Find.Replacement.ClearFormatting
            With Selection.Find
                .Text = "^13█([0-9])([0-9])([0-9]).【解析】"
                .Replacement.Text = "^13【解析】"
                .Forward = True
                .Wrap = wdFindContinue
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchByte = False
                .MatchAllWordForms = False
                .MatchSoundsLike = False
                .MatchWildcards = True
            End With
            Selection.Find.Execute Replace:=wdReplaceAll
            
            
            Selection.Find.ClearFormatting
            Selection.Find.Replacement.ClearFormatting
            With Selection.Find
                .Text = "^13█([0-9])([0-9]).【解析】"
                .Replacement.Text = "^13【解析】"
                .Forward = True
                .Wrap = wdFindContinue
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchByte = False
                .MatchAllWordForms = False
                .MatchSoundsLike = False
                .MatchWildcards = True
            End With
            Selection.Find.Execute Replace:=wdReplaceAll
            
            
            Selection.Find.ClearFormatting
            Selection.Find.Replacement.ClearFormatting
            With Selection.Find
                .Text = "^13█([0-9]).【解析】"
                .Replacement.Text = "^13【解析】"
                .Forward = True
                .Wrap = wdFindContinue
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchByte = False
                .MatchAllWordForms = False
                .MatchSoundsLike = False
                .MatchWildcards = True
            End With
            Selection.Find.Execute Replace:=wdReplaceAll
            
            


  Dim 定位词 As String
    定位词 = "【解析】"
    Dim 题号词 As String
    题号词 = "█([0-9]{1,})."
    Dim 本段 As Paragraph
    For Each 本段 In ActiveDocument.Paragraphs       '''''1遍历活动文档所有段落
        If InStr(1, 本段.range.Text, 定位词) > 0 Then         ''''2如果本段搜到定位词【解析】
            If InStr(1, 本段.Previous.range.Text, 题号) > 0 Then        ''''3如果本段搜到题号词【█111.】
            
                本段.Previous.range.Select                      '''''''''4选择本段前一段
                With Selection.Find                      '''''''''5搜索题号词
                    .Text = 题号词
                    .Forward = True
                    .Wrap = wdFindStop
                    .Format = False
                    .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = True
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                    If .Execute Then                  '''''''''6如果存在题号词
                        Selection.Copy                '''''7复制题号词
                        本段.range.Select             '''''8选择本段落
                        Selection.Move wdParagraph, -1     '''''9光标移动到段落头
                        本段.range.Collapse Direction:=wdCollapseStart   ''''10光标移到本段
                        Selection.Paste      ''''''11粘贴刚才的复制
                    End If
                End With
            End If
        End If
    Next 本段  ' ' ' ' '█8遍历下一个含词段落
   
   
End Sub