如何把word文档中除表格外的全部段落按字符量插入自动编号

不空善成

Sub 自动编辑附注()

   Selection.Find.ClearFormatting

   Selection.Find.Replacement.ClearFormatting

   With Selection.Find

       .Text = "^p^p"

       .Replacement.Text = "^p"

       .Forward = True

       .Wrap = wdFindContinue

       .Format = False

        .MatchCase = False

       .MatchWholeWord = False

       .MatchByte = True

       .MatchWildcards = False

       .MatchSoundsLike = False

       .MatchAllWordForms = False

   End With

   Selection.Find.Execute Replace:=wdReplaceAll

   Selection.Find.Execute Replace:=wdReplaceAll

   Selection.Find.Execute Replace:=wdReplaceAll

   Selection.Find.Execute Replace:=wdReplaceAll

   Selection.Find.Execute Replace:=wdReplaceAll

   Selection.Find.Execute Replace:=wdReplaceAll

   Selection.WholeStory

   Selection.Find.ClearFormatting

   Selection.Find.Replacement.ClearFormatting

   ActiveDocument.Content.Find.Execute FindText:=" ",ReplaceWith:="", Replace:=wdReplaceAll

   Selection.Find.Execute Replace:=wdReplaceAll

    Selection.Fields.Unlink

    Dim i%

   Dim aTable As Table

   Application.ScreenUpdating = False

   For Each aTable In ActiveDocument.Tables

       With aTable.Cell(1, 1).Range

           Do

                .Expand wdRow

                If .Text Like "*[!"& Chr(7) & Chr(13) & " 　]*" = False Then

                    .Rows.Delete

                    i = i + 1

                Else

                     .Move wdCell

                End If

           Loop Until .End = aTable.Range.End

       End With

   Next

   Application.Browser.Target = wdBrowseTable

   For i = 1 To ActiveDocument.Tables.Count 'For

   With Selection

   ActiveDocument.Tables.Item(i).Select

       With .Shading

           .Texture = wdTextureNone

           .ForegroundPatternColor = wdColorAutomatic

            .BackgroundPatternColor = -603914241

       End With

       With .Borders(wdBorderTop)

           .LineStyle = wdLineStyleSingle

           .LineWidth = wdLineWidth150pt

           .Color = wdColorAutomatic

       End With

       With .Borders(wdBorderBottom)

           .LineStyle = wdLineStyleSingle

           .LineWidth = wdLineWidth150pt

           .Color = wdColorAutomatic

       End With

       With .Borders(wdBorderHorizontal)

           .LineStyle = wdLineStyleSingle

           .LineWidth = wdLineWidth050pt

           .Color = wdColorAutomatic

       End With

       With .Borders(wdBorderVertical)

           .LineStyle = wdLineStyleSingle

           .LineWidth = wdLineWidth050pt

           .Color = wdColorAutomatic

       End With

       .Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone

       .Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone

       .Borders.Shadow = False

   End With

   With Options

       .DefaultBorderLineStyle = wdLineStyleSingle

       .DefaultBorderLineWidth = wdLineWidth050pt

       .DefaultBorderColor = wdColorAutomatic

   End With

   

   Next i

   

   Dim p As Paragraph

   ActiveDocument.DeleteAllEditableRanges wdEditorEveryone

   For Each p In ActiveDocument.Paragraphs

       If p.Range.Information(wdWithInTable) = False Then

           p.Range.Editors.Add wdEditorEveryone

       End If

   Next

   ActiveDocument.SelectAllEditableRanges wdEditorEveryone

   ActiveDocument.DeleteAllEditableRanges wdEditorEveryone

   Selection.Font.Color = wdColorRed

End Sub

batmanbbs

晕，这和字符数量有啥关系啊，有的一级标题比二级标题还长呢：D

batmanbbs

你规范一下：二级标题最后以"："结尾应该还是可以处理的

不空善成

我不懂编这些代码的，是在网上找后多个代码串接成的，各位大神，帮编写下代码吧，谢谢。

batmanbbs

1. Sub 添加编号()
   
2. '
   
3. ' 添加编号（删除空段落、规范表格、添加自动编号）
   
4. '
   
5.     Application.ScreenUpdating = False
   
6. 
   
7.     Dim myTB As Table, myPG As Paragraph
   
8.     Dim isL1 As Boolean, L%, s$, defSpace$
   
9. 
   
10.     ' 设置一级自动编号
    
11.     With ListGalleries(wdNumberGallery).ListTemplates(1).ListLevels(1)
    
12.         .NumberFormat = "（%1）"
    
13.         .NumberStyle = wdListNumberStyleSimpChinNum1
    
14.         .NumberPosition = 0
    
15.         .TrailingCharacter = wdTrailingNone
    
16.         .Alignment = wdListLevelAlignLeft
    
17.         .ResetOnHigher = 0
    
18.         .StartAt = 1
    
19.         With .Font
    
20.             .Name = "宋体"
    
21.             .Bold = False
    
22.             .Size = 11
    
23.         End With
    
24.         .LinkedStyle = ""
    
25.     End With
    
26. 
    
27.     With ActiveDocument
    
28.         ' 删除空段落
    
29.         With .Range.Find
    
30.             .ClearFormatting
    
31.             .Replacement.ClearFormatting
    
32.             .Text = "^13{2,}"
    
33.             .Replacement.Text = "^13"
    
34.             .Forward = True        ' 向下查找：是
    
35.             .Wrap = wdFindContinue
    
36.             .MatchWildcards = True
    
37.             .Format = False        ' 格式：否
    
38.             .MatchCase = False        ' 区分大小写：否
    
39.             .MatchWholeWord = False        ' 全字匹配：否
    
40.             .MatchByte = False        ' 是否区分全/半角：否
    
41.             .Execute Replace:=wdReplaceAll
    
42.         End With
    
43. 
    
44.         defSpace = " 　" & Chr(7) & Chr(9) & Chr(11) & Chr(13) & Chr(160)
    
45.         isL1 = True: L = 0
    
46.         With .Range(0, 0)
    
47.             Do
    
48.                 If .Information(wdWithInTable) Then
    
49.                     isL1 = True
    
50.                     Set myTB = .Tables(1)
    
51.                     With myTB
    
52.                         ' 设置表格框线
    
53.                         .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
    
54.                         .Borders(wdBorderRight).LineStyle = wdLineStyleNon
    
55.                         .Borders(wdBorderTop).LineStyle = wdLineStyleSingle
    
56.                         .Borders(wdBorderTop).LineWidth = wdLineWidth150pt
    
57.                         .Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
    
58.                         .Borders(wdBorderBottom).LineWidth = wdLineWidth150pt
    
59.                         .Borders.InsideLineStyle = wdLineStyleSingle
    
60.                         .Borders.InsideLineWidth = wdLineWidth075pt
    
61.                         ' 删除表格空行
    
62.                         With .Cell(1, 1).Range
    
63.                             Do
    
64.                                 .Expand wdRow
    
65.                                 If .Text Like "*[!" & defSpace & "]*" Then
    
66.                                     .Move wdCell
    
67.                                 Else
    
68.                                     .Rows.Delete
    
69.                                 End If
    
70.                             Loop Until .End = myTB.Range.End
    
71.                         End With
    
72.                     End With
    
73.                     .Expand wdTable: .Move
    
74.                 Else
    
75.                     ' 添加编号
    
76.                     Set myPG = .Paragraphs(1)
    
77.                     With myPG.Range
    
78.                         s = Trim(Left(.Text, Len(.Text) - 1))
    
79.                         If Len(s) > 0 Then
    
80.                             If .Characters(1) Like "[ 123456789]" Then .Characters(1).Delete
    
81.                             If Not isL1 Or Right(s, 1) Like "[:：]" Or s Like "*明细前五名" Then        ' 添加二级计数编号（不具有通用性）
    
82.                                 isL1 = True: L = L + 1: .InsertBefore L
    
83.                             Else ' 添加一级编号（自动编号）
    
84.                                 isL1 = False: L = 0
    
85.                                 .ListFormat.ApplyListTemplateWithLevel _
    
86.                                         ListTemplate:=ListGalleries(wdNumberGallery).ListTemplates(1), _
    
87.                                         ContinuePreviousList:=True, _
    
88.                                         ApplyTo:=wdListApplyToWholeList, _
    
89.                                         DefaultListBehavior:=wdWord10ListBehavior
    
90.                             End If
    
91.                             With .ParagraphFormat
    
92.                                 .LeftIndent = 0
    
93.                                 .CharacterUnitFirstLineIndent = 2
    
94.                             End With
    
95.                         End If
    
96.                     End With
    
97.                     .Move wdParagraph
    
98.                 End If
    
99.             Loop Until .End = ActiveDocument.Content.End - 1
    
100.         End With
     
101.     End With
     
102. 
     
103.     Set myPG = Nothing
     
104.     Set myTB = Nothing
     
105. 
     
106.     Application.ScreenUpdating = True
     
107. 
     
108. End Sub

复制代码

batmanbbs

该代码完全是根据你提供的文档编写的，因此不具有通用性，特别是二级编号采用的是你文档中的计数编号（非自动编号）。另外，二级编号对应的二级标题除了你文档中的内容外，也不具有扩展性。建议你最好规范一下二级标题（比如我上面提到的段落结尾都是"："），才能使代码应用的更广泛一些。

我没有添加颜色，如果需要可以自己修改一下。

BTW：你的要求可不仅仅是你标题所述，相关要求其实比较复杂，涉及段落、表格、自动编号等处理。

不空善成

batmanbbs 发表于 2023-5-6 10:14
该代码完全是根据你提供的文档编写的，因此不具有通用性，特别是二级编号采用的是你文档中的计数编号（非自 ...

我上面的代码，只运行到全选除表格的段落，插入自动编号要手动添加修改，二级段落结尾可以全部是“：”，自动编号代码如何修改添加。

batmanbbs

不空善成 发表于 2023-5-6 11:22
我上面的代码，只运行到全选除表格的段落，插入自动编号要手动添加修改，二级段落结尾可以全部是“：”， ...

没有听明白，代码执行错误了吗？截图看一下

batmanbbs

1. Sub 添加编号()
   
2. '
   
3. ' 添加编号（删除空段落、规范表格、添加自动编号）
   
4. '
   
5.     Application.ScreenUpdating = False
   
6. 
   
7.     Dim myTB As Table, myPG As Paragraph
   
8.     Dim L%, s$, defSpace$
   
9. 
   
10.     ' 设置一级自动编号
    
11.     With ListGalleries(wdNumberGallery).ListTemplates(1).ListLevels(1)
    
12.         .NumberFormat = "（%1）"
    
13.         .NumberStyle = wdListNumberStyleSimpChinNum1
    
14.         .NumberPosition = 0
    
15.         .TrailingCharacter = wdTrailingNone
    
16.         .Alignment = wdListLevelAlignLeft
    
17.         .ResetOnHigher = 0
    
18.         .StartAt = 1
    
19.         With .Font
    
20.             .Name = "宋体"
    
21.             .Bold = False
    
22.             .Size = 11
    
23.         End With
    
24.         .LinkedStyle = ""
    
25.     End With
    
26.     ' 设置二级自动编号
    
27.     With ListGalleries(wdNumberGallery).ListTemplates(2).ListLevels(1)
    
28.         .NumberFormat = "%1、"
    
29.         .NumberStyle = wdListNumberStyleArabic
    
30.         .NumberPosition = 0
    
31.         .TrailingCharacter = wdTrailingNone
    
32.         .Alignment = wdListLevelAlignLeft
    
33.         .ResetOnHigher = 0
    
34.         .StartAt = 1
    
35.         With .Font
    
36.             .Name = "宋体"
    
37.             .Bold = False
    
38.             .Size = 11
    
39.         End With
    
40.         .LinkedStyle = ""
    
41.     End With
    
42. 
    
43.     With ActiveDocument
    
44.         ' 删除空段落
    
45.         With .Range.Find
    
46.             .ClearFormatting
    
47.             .Replacement.ClearFormatting
    
48.             .Text = "^13{2,}"
    
49.             .Replacement.Text = "^13"
    
50.             .Forward = True
    
51.             .Wrap = wdFindContinue
    
52.             .MatchWildcards = True
    
53.             .Format = False
    
54.             .MatchCase = False
    
55.             .MatchWholeWord = False
    
56.             .MatchByte = False
    
57.             .Execute Replace:=wdReplaceAll
    
58.         End With
    
59. 
    
60.         defSpace = " 　" & Chr(7) & Chr(9) & Chr(11) & Chr(13) & Chr(160)
    
61.         L = 0
    
62.         With .Range(0, 0)
    
63.             Do
    
64.                 If .Information(wdWithInTable) Then
    
65.                     Set myTB = .Tables(1)
    
66.                     With myTB
    
67.                         ' 设置表格框线
    
68.                         .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
    
69.                         .Borders(wdBorderRight).LineStyle = wdLineStyleNon
    
70.                         .Borders(wdBorderTop).LineStyle = wdLineStyleSingle
    
71.                         .Borders(wdBorderTop).LineWidth = wdLineWidth150pt
    
72.                         .Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
    
73.                         .Borders(wdBorderBottom).LineWidth = wdLineWidth150pt
    
74.                         .Borders.InsideLineStyle = wdLineStyleSingle
    
75.                         .Borders.InsideLineWidth = wdLineWidth075pt
    
76.                         ' 删除表格空行
    
77.                         With .Cell(1, 1).Range
    
78.                             Do
    
79.                                 .Expand wdRow
    
80.                                 If .Text Like "*[!" & defSpace & "]*" Then
    
81.                                     .Move wdCell
    
82.                                 Else
    
83.                                     .Rows.Delete
    
84.                                 End If
    
85.                             Loop Until .End = myTB.Range.End
    
86.                         End With
    
87.                     End With
    
88.                     .Expand wdTable: .Move
    
89.                 Else
    
90.                     ' 添加编号
    
91.                     Set myPG = .Paragraphs(1)
    
92.                     With myPG.Range
    
93.                         s = Trim(Left(.Text, Len(.Text) - 1))
    
94.                         If Len(s) > 0 Then
    
95.                             If .Characters(1) = " " Then .Characters(1).Delete
    
96.                             If .Characters(1) = "、" Then .Characters(1).Delete
    
97.                             If Right(s, 1) Like "[:：]" Then        ' 添加二级自动编号
    
98.                                 L = L + 1
    
99.                                 .ListFormat.ApplyListTemplateWithLevel _
    
100.                                         ListTemplate:=ListGalleries(wdNumberGallery).ListTemplates(2), _
     
101.                                         ContinuePreviousList:=(L <> 1), _
     
102.                                         ApplyTo:=wdListApplyToWholeList, _
     
103.                                         DefaultListBehavior:=wdWord10ListBehavior
     
104.                             Else ' 添加一级编号（自动编号）
     
105.                                 L = 0
     
106.                                 .ListFormat.ApplyListTemplateWithLevel _
     
107.                                         ListTemplate:=ListGalleries(wdNumberGallery).ListTemplates(1), _
     
108.                                         ContinuePreviousList:=True, _
     
109.                                         ApplyTo:=wdListApplyToWholeList, _
     
110.                                         DefaultListBehavior:=wdWord10ListBehavior
     
111.                             End If
     
112.                             With .ParagraphFormat
     
113.                                 .LeftIndent = 0
     
114.                                 .CharacterUnitFirstLineIndent = 2
     
115.                             End With
     
116.                         End If
     
117.                     End With
     
118.                     .Move wdParagraph
     
119.                 End If
     
120.             Loop Until .End = ActiveDocument.Content.End - 1
     
121.         End With
     
122.     End With
     
123. 
     
124.     Set myPG = Nothing
     
125.     Set myTB = Nothing
     
126. 
     
127.     Application.ScreenUpdating = True
     
128. 
     
129. End Sub

复制代码

batmanbbs

如二级标题可以确定以"："结尾，可以使用修改后的代码（二级编号也是自动编号）
PS：你可以修改第97句代码，来适应你的二级标题特征。