500多份文档表格格式修改

413191246se

楼主，你提供的附件样稿中，欲改文档和改好文档两相对照，不一样啊！（怎么1、4桩变成了2、4桩？）。
还有，你应该把要设置格式的地方变成红色字体，这样才鲜明！
再有，你说表头什么什么格式，但据我所知，所谓表头，其实是表格第一行文字（你的表头意思是表格之小标题），这个我不敢苟同！
——想帮忙吧，但就是没看明白，该怎么做。
——请楼主，重新提供两相对照的新样稿附件（我虽然很笨，但也会一点点VBA编程）。。。

413191246se

欲改文档，应提供3-5个文档做为示例；改好文档，仅提供一个示例文档即可，并以红色标注已经修改的地方。

Lightem

多谢楼上的建议。

413191246se

谢谢楼主！但是非常抱歉，我还是没看明白怎么做！就是表格太多了，给我整懵了。

loquat

楼主的表格太不规范了，表格之前的内容可能是1行-3行，做起来懵。
给个表格规范时的中间过程吧，希望楼主有能力研究

1. Sub 批量修改_MeThee()
   
2. On Error Resume Next
   
3. Application.ScreenUpdating = False
   
4. Dim aPath$, arr, aDoc As Document
   
5. Dim aTable As Table, aRange As Range
   
6. Dim aTableCount&, aParaCount, aLength&, bLength&
   
7. Dim aSectionCount&
   
8. aPath = ThisDocument.Path
   
9. arr = mySearch(aPath & "\107\*.doc")  '遍历结果
   
10. iLbound = LBound(arr)
    
11. iUbound = UBound(arr)
    
12. For i = iLbound To iUbound - 1
    
13.     If InStr(1, arr(i), "~") = 0 Then
    
14.         Set aDoc = Documents.Open(arr(i))
    
15.         aSectionCount = aDoc.Sections.Count
    
16.         For j = 1 To aSectionCount
    
17.             With aDoc.Sections(j).PageSetup
    
18.                 .TopMargin = CentimetersToPoints(2)
    
19.                 .BottomMargin = CentimetersToPoints(2)
    
20.                 .LeftMargin = CentimetersToPoints(2.5)
    
21.                 .RightMargin = CentimetersToPoints(1.5)
    
22.                 '.HeaderDistance = 1.5
    
23.                 '.FooterDistance = 1.75
    
24.             End With
    
25.         Next j
    
26.         aTableCount = aDoc.Tables.Count
    
27.         For j = 1 To aTableCount
    
28.             Set aTable = aDoc.Tables(j)
    
29.             aParaCount = aDoc.Range(0, aTable.Range.Start).Paragraphs.Count
    
30.             Set aRange = aDoc.Paragraphs(aParaCount - 2).Range
    
31.             aRange.SetRange aRange.Start, aRange.End - 1
    
32.             With aRange '设置第一行格式
    
33.                 .Font.Name = "宋体"
    
34.                 .Font.Size = 15
    
35.                 .Font.Bold = True
    
36.                 .Font.Spacing = 3  '设置字距
    
37.                 .ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
    
38.                 .ParagraphFormat.LineSpacing = 22
    
39.                 .ParagraphFormat.Alignment = wdAlignParagraphCenter
    
40.             End With
    
41.             aLength = myLength(aRange)
    
42.             Set aRange = aDoc.Paragraphs(aParaCount - 1).Range
    
43.             aRange.SetRange aRange.Start, aRange.End - 1
    
44.             aRange.Text = VBA.Trim$(aRange.Text)
    
45.             With aRange
    
46.                 .Font.Name = "宋体"
    
47.                 .Font.Size = 18
    
48.                 .Font.Bold = True
    
49.                 .ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
    
50.                 .ParagraphFormat.LineSpacing = 22
    
51.                 .ParagraphFormat.Alignment = wdAlignParagraphCenter
    
52.                 '根据特殊要求调整字距
    
53.                 aSpacing = .Font.Spacing
    
54.                 aChrCount = .Characters.Count
    
55.                 aRange.SetRange aRange.Start, aRange.End - 1
    
56.                 bLength = myLength(aRange)
    
57.                 aRange.Select
    
58. s:
    
59.                 If bLength < aLength Then
    
60.                     Selection.Font.Spacing = Selection.Font.Spacing + 1
    
61.                     bLength = myLength(aRange)
    
62.                     If bLength < aLength Then GoTo s
    
63.                 End If
    
64.                 .Font.Spacing = .Font.Spacing + 0.5
    
65.             End With
    
66.             With aRange.Find
    
67.                 Set bRange = aRange
    
68.                 .ClearFormatting
    
69.                 .MatchWildcards = True
    
70.                 .Text = "[0-9A-Za-z]{2}"
    
71.                 .Forward = True
    
72.                 .Wrap = wdFindStop
    
73.                 Do While .Execute = True
    
74.                     Set aRange = .Parent
    
75.                     aRange.SetRange aRange.Start, aRange.End - 1
    
76.                     aRange.Font.Spacing = 0
    
77.                     aRange.SetRange aRange.End, bRange.End
    
78.                 Loop
    
79.             End With
    
80.             Set aRange = aDoc.Paragraphs(aParaCount).Range
    
81.             With aRange
    
82.                 .Font.Name = "宋体"
    
83.                 .Font.Size = 10
    
84.             End With
    
85.             '标题段格式设置完成
    
86.             With aTable.Range.Font
    
87.                 .Name = "宋体"  '设置表格字体
    
88.                 .Size = 9
    
89.                 .Bold = False   '去除加粗
    
90.             End With
    
91.             '这里是其他操作
    
92.         Next j
    
93.         aDoc.Close True  '保存关闭
    
94.         End If
    
95. Next i
    
96. Application.ScreenUpdating = True
    
97. End Sub
    

复制代码

1. Enum aSearchType
   
2.     aSearchTypeFolder = 0
   
3.     aSearchTypeFile = 1
   
4.     aSearchTypeAll = 2
   
5. End Enum
   
6. 
   
7. Function mySearch(aPath$, Optional searchTraversal As Boolean = True, Optional searchType As aSearchType = aSearchTypeFile) As String()
   
8. '参数1：遍历目录全路径
   
9. '参数2：是否搜索子目录
   
10. '参数3：搜索文件、目录或者全部
    
11. Dim aNum&, cmdStr$, folder$, aTemp$
    
12. folder = """" & aPath & """"
    
13. cmdStr = Environ$("comspec") & " /c dir " & folder   '初始化字串
    
14. If searchTraversal Then cmdStr = cmdStr & " /s"      '定义是否遍历
    
15. aTemp = Mid(aPath, InStrRev(aPath, "") + 1)         '获取最后一个""后的内容
    
16. If Left(aTemp, 2) = "*." Then searchType = aSearchTypeFile
    
17. If searchType = aSearchTypeFile Then                 '定义搜索文件、目录还是全部
    
18.     cmdStr = cmdStr & " /a:-d /b"
    
19. ElseIf searchType = aSearchTypeFolder Then
    
20.     cmdStr = cmdStr & " /a:d /b"
    
21. ElseIf searchType = aSearchTypeAll Then
    
22.     cmdStr = cmdStr & " /b"
    
23. End If
    
24. cmdStr = cmdStr & " > C:\aTemp.txt"
    
25. With CreateObject("WScript.Shell")
    
26.        .Run cmdStr, 0, True
    
27. End With
    
28. aNum = FreeFile
    
29. Open "C:\aTemp.txt" For Input As #aNum
    
30.     mySearch = Split(StrConv(InputB(LOF(aNum), aNum), vbUnicode), vbCrLf)
    
31. Close #aNum
    
32. End Function
    
33. 
    
34. Public Function myRegExp(ByVal str$, ByVal aPattern$)
    
35. With CreateObject("Vbscript.RegExp")
    
36.     .Global = True
    
37.     .Pattern = aPattern    '"[^一-﨩]"
    
38.     myRegExp = .Replace(str, "")
    
39. End With
    
40. End Function
    
41. 
    
42. Function myLength(aRange As Range)
    
43. Dim aLeft&, aRight&
    
44. Dim aStart&, aEnd&
    
45. aStart = aRange.Start
    
46. aEnd = aRange.End
    
47. With aRange
    
48.     aLeft = .Information(wdHorizontalPositionRelativeToPage)
    
49.     .SetRange .End, .End
    
50.     aRight = .Information(wdHorizontalPositionRelativeToPage)
    
51.     .SetRange aStart, aEnd
    
52. End With
    
53. myLength = Abs(aRight - aLeft)
    
54. End Function

复制代码

hankou2009

4月份的帖子了，来晚了