如何实现Word根据目录文件进行批量上下标？

ming0018

自己把空行去掉，看起来太吓人了，如果分几个sub去写可能看清晰。

ming0018

1. Sub main_批量上标test()
   
2.     '------------------------------------上面这部分主要是把原文字和上下标存入数组
   
3.     Dim doc As Document, n%, Str_Original() As String, Str_Superscript() As String, Str_Subscript() As String
   
4.     Set doc = ActiveDocument: n = 1
   
5.     ReDim Preserve Str_Original(1 To n)
   
6.     ReDim Preserve Str_Superscript(1 To n) '上标
   
7.     ReDim Preserve Str_Subscript(1 To n)   '下标
   
8.     Str_Original(1) = "KAl(SO4)2": Str_Superscript(1) = "AL": Str_Subscript(1) = "4,2"   '下标不同时用逗号隔开
   
9.     'Str_Original(2) = "KAl(SO4)2": Str_Superscript(2) = "AL": Str_Subscript(2) = "4,2"
   
10.     'Str_Original(3) = "KAl(SO4)2": Str_Superscript(3) = "AL": Str_Subscript(3) = "4,2"
    
11.     '如果少的话，可以自己往后加
    
12.     '------------------------------------下面这部分主要遍历组数，用查找替换的方式分别对字符串上下标
    
13.     Dim Str_Start&, Str_End&, Rng As Range, Str_Superscript_Arr() As String, Str_Subscript_Arr() As String
    
14.     For i = 1 To UBound(Str_Original)
    
15.         Call findstr_批量上标(Str_Original(i), Str_Superscript(i), Str_Subscript(i))
    
16.     Next i
    
17. End Sub
    
18. 
    
19. Sub findstr_批量上标(findStr$, Str_Super$, Str_Sub$)
    
20.     Dim doc As Document, Str_Start&, Str_End&, Str_Superscript_Arr() As String, Str_Subscript_Arr() As String
    
21.     Set doc = ActiveDocument
    
22.     With doc.Content.Find
    
23.         .Text = findStr
    
24.         Do While .Execute
    
25.             Str_Start = .Parent.Start: Str_End = .Parent.End
    
26.             If Str_Super <> "" Then
    
27.                 Str_Superscript_Arr = Split(Str_Super, ",")
    
28.                 For j = 0 To UBound(Str_Superscript_Arr)
    
29.                     Call set上标_批量上标(Str_Start, Str_End, Str_Superscript_Arr(j))
    
30.                 Next j
    
31.             End If
    
32.             If Str_Sub <> "" Then
    
33.                 Str_Subscript_Arr = Split(Str_Sub, ",")
    
34.                 For j = 0 To UBound(Str_Subscript_Arr)
    
35.                     Call set下标_批量上标(Str_Start, Str_End, Str_Subscript_Arr(j))
    
36.                 Next j
    
37.             End If
    
38.         Loop
    
39.     End With
    
40. End Sub
    
41. 
    
42. Sub set上标_批量上标(S_Start&, S_End&, S_Super$)
    
43.     Dim doc As Document, Rng As Range
    
44.     Set doc = ActiveDocument: Set Rng = doc.Range(S_Start, S_End)
    
45.     With Rng.Find
    
46.         .Text = S_Super
    
47.         .Replacement.Font.Superscript = True
    
48.         .Execute Replace:=wdReplaceAll
    
49.     End With
    
50. End Sub
    
51. 
    
52. Sub set下标_批量上标(S_Start&, S_End&, S_Sup$)
    
53.     Dim doc As Document, Rng As Range
    
54.     Set doc = ActiveDocument: Set Rng = doc.Range(S_Start, S_End)
    
55.     With Rng.Find
    
56.         .Text = S_Sup
    
57.         .Replacement.Font.Subscript = True
    
58.         .Execute Replace:=wdReplaceAll
    
59.     End With
    
60. End Sub

复制代码

lhw721

ming0018 发表于 2018-11-29 16:54

ming0018兄，为什么我执行宏都没有任何反应？应该要如何操作？

ming0018

lhw721 发表于 2018-11-30 08:27
ming0018兄，为什么我执行宏都没有任何反应？应该要如何操作？

因为上面的代码不是给你的

wdpfox

ming0018 发表于 2018-11-29 16:54

ming0018老师，如果把上下标改为大小写的话，如何实现？比如：pm2.5，要写成：大写PM2.5，25km/h，写成25Km/h，所以就想到要区分大小写，用读取列表方式如何实现？请指教，谢谢！

ming0018

wdpfox 发表于 2018-12-10 11:12
ming0018老师，如果把上下标改为大小写的话，如何实现？比如：pm2.5，要写成：大写PM2.5，25km/h，写成25 ...

用excel记录你要上下标或者说大小写的字符串，然后用ado+sql找到哪些要大写的字符串。
大写：.Range.Case = wdUpperCase
小写：.Range.Case = wdLowerCase

wdpfox

ming0018 发表于 2018-12-10 12:00
用excel记录你要上下标或者说大小写的字符串，然后用ado+sql找到哪些要大写的字符串。
大写：.Range.Cas ...

尽管不太明白，还是谢谢！

wangweixiang11

cuteword 发表于 2018-11-17 22:26
下载吧中的是最后一次更新版本，支持64位office，https://xiazai.xiazaiba.com/Soft/W/WordlgbbxGx_1.6.5.0 ...

不能增加上下标的数据，加上去也保存不了

我也来学vab

ming0018 发表于 2018-11-28 11:06
请看一下附件是否是您要的效果。

请问后老师最后是如何根据目录文件的替换要求对“案例”进行修改的呢，能否提供一下改动后的代码，万分感谢！

我也来学vab

请问能不能展示一下案例修改的代码