VBA按大标题分页，“十一”之后就不分了，求大神帮忙

lhteee

代码如下：

Sub 按大标题分页()

   Dim range As range

   Dim foundRange As range

   Dim j As Integer

   Application.ScreenUpdating = False

   For Each Paragraph In ActiveDocument.Paragraphs

       '在每次迭代中更新字符串变量

       For j = 1 To 64

           ' 检查段落是否包含完整的匹配字符串

           If InStr(Paragraph.range.Text, Mid("一、二、三、四、五、六、七、八、九、十、十一、十二、十三、十四、十五、十六、十七、十八、十九、二十、二十一、二十二、二十三、二十四、二十五、二十六、二十七、二十八、二十九、三十、三十一、三十二、三十三、三十四、三十五", j, 1) & "、") = 1 Then

                Set foundRange =Paragraph.range.Duplicate

                ' 移动到找到文字的开始位置

                foundRange.CollapsewdCollapseStart

                ' 在找到的文字前插入分页符

                foundRange.InsertBeforeChrW(&HC)

                ' 使用Collapse方法确保分页符不会影响文档内容

                foundRange.CollapsewdCollapseEnd

           End If

       Next j

   Next Paragraph

Exit Sub

VeryEnd:

   Application.ScreenUpdating = True

End Sub

举例.rar (29.42 KB, 下载次数: 5)

2024-7-22 08:18 上传

点击文件名下载附件
这是示例文件

lhteee

问题应该出在这行代码，但不知道怎么改。
  If InStr(Paragraph.range.Text, Mid("一、二、三、四、五、六、七、八、九、十、十一、十二、十三、十四、十五、十六、十七、十八、十九、二十、二十一、二十二、二十三、二十四、二十五、二十六、二十七、二十八、二十九、三十、三十一、三十二、三十三、三十四、三十五", j, 1) & "、") = 1

zhanglei1371

原来是AI生成的代码。那就没啥意思了。多问问，用正宗的Chatgpt吧。

batmanbbs

条件打错字了，应该是"一二三四五六七八九十"，自己改一下

lhteee

batmanbbs 发表于 2024-7-22 10:18
条件打错字了，应该是"一二三四五六七八九十"，自己改一下

很好，少个“四”。谢谢！！！

lhteee

zhanglei1371 发表于 2024-7-22 10:10
顺序倒过来，一放到最后，三十五放到第一个

我试一下，谢谢！！！

lhteee

zhanglei1371 发表于 2024-7-22 10:10
顺序倒过来，一放到最后，三十五放到第一个

同样止步于“十一”。

gwjkkkkk

Option Explicit
Sub TEST()
    Dim ar(), i&, r&, n&, regEx As Object, Par As Paragraph
   
    Application.ScreenUpdating = False
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Pattern = "^[一二三四五六七八九十]+、"

    With ThisDocument
        .Range(.Content.Start, .Content.End - 1).Copy
    End With
   
    With Documents.Add
        .Range(0).Paste
        For Each Par In .Paragraphs
            If regEx.TEST(Par.Range.Text) Then
                r = r + 1
                ReDim Preserve ar(1 To r)
                Set ar(r) = .Range(Par.Range.Start, Par.Range.Start)
            End If
        Next
        For i = 2 To UBound(ar)
            ar(i).InsertBreak 7
        Next i
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。

lhteee

gwjkkkkk 发表于 2024-7-22 20:07
请参考附件。。。

🙏谢谢🙏，可以实现想要的。