[求助]编程实现上下行中部分文字对齐

firewzy

使用vba编程时，碰到需要将两行中的部分文字对齐，我想将下面修改前文档中的“计算日期”与下行中的“界址点数”使用TAB对齐。努力了很久，没有解答。望各位大大教我。

我的代码如下：

Sub a() Dim a As Integer, b As Integer, c As Integer Dim i As Paragraph Dim myrange As Range For Each i In ActiveDocument.Paragraphs If i.Range.Find.Execute(FindText:="计算日期", Forward:=True, Wrap:=wdFindStop) = True Then Set myrange = ActiveDocument.Range(i.Range.Start, i.Next.Range.End - 1) With i.Range.Find .Execute FindText:="计算日期", Forward:=True a = .Parent.Information(wdHorizontalPositionRelativeToPage) End With With myrange.Find .Execute FindText:="界址点数", Forward:=True b = .Parent.Information(wdHorizontalPositionRelativeToPage) c = a - b MsgBox c If c < 0 Then myrange = VBA.Replace(myrange, jsrqtext, String(-c, 9) & jsrqtext) ElseIf c > 0 Then myrange = VBA.Replace(myrange, jzdstext, String(c, 9) & jzdstext) End If End With End If Next End Sub

文档处理修改前：

宗地面积量算表

土地使用者:北京经济技术开发区

土地坐落: 北门口村1

地类号:

面积(平米):16022.9 计算日期: 2005年7月12日

宗地编号: 北门口村1总面积 界址点数: 24

宗地面积量算表

土地使用者:北京经济技术开发区

土地坐落: 北门口村2

地类号:

面积(平米):205007.4 计算日期: 2005年7月12日

宗地编号: 北门口村2总面积 界址点数: 78

文档处理修改后：

宗地面积量算表

土地使用者:北京经济技术开发区

土地坐落: 北门口村1

地类号:

面积(平米):16022.9 计算日期: 2005年7月12日

宗地编号: 北门口村1总面积 界址点数: 24

宗地面积量算表

土地使用者:北京经济技术开发区

土地坐落: 北门口村2

地类号:

面积(平米):205007.4 计算日期: 2005年7月12日

宗地编号: 北门口村2总面积 界址点数: 78

附带修改前后文本：

dFLmpcU2.rar (20.4 KB, 下载次数: 30)

2005-7-14 17:29 上传

点击文件名下载附件
[求助]编程实现上下行中部分文字对齐

守柔

请参考：

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By I Love You_Word!@ExcelHome 2005-7-14 20:48:49 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Option Explicit Sub Example() Dim MyFindRange As Range, Pos As Integer Dim KeyRange As Range, i As Paragraph Application.ScreenUpdating = False '关闭屏幕更新 With ActiveDocument For Each i In .Paragraphs With i If VBA.InStr(.Range, "计算日期:") > 0 Or VBA.InStr(.Range, "界址点数:") > 0 Then .Range.Find.Execute findtext:="^t", replacewith:="", Replace:=wdReplaceAll '在文档的8厘米处增加一个制表位 .TabStops.Add Position:=Word.CentimetersToPoints(8) Pos = VBA.IIf(VBA.InStr(.Range, "计算日期:") > 0, VBA.InStr(.Range, "计算日期:"), VBA.InStr(.Range, "界址点数:")) '取得指定的文本所在位置的RANGE对象 Set KeyRange = ActiveDocument.Range(.Range.Start + Pos - 1, .Range.Start + Pos - 1) '插入一个TAB键(移至指定制表位) KeyRange.InsertAfter vbTab End If End With Next End With Application.ScreenUpdating = True '恢复屏幕更新 End Sub '----------------------

firewzy

崇拜死守柔了

守柔

二楼的代码，自我感觉很不好。抽空重新做了一个，应该运行速度大大高于在段落中的循环了。

请楼主再试用一下：

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By I Love You_Word!@ExcelHome 2005-7-18 15:43:54 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '№ 0003^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub Example2() Dim MyFindRange As Range, MyFindText As Variant, aText As Variant Dim Pos As Long, MyRange As Range ' Debug.Print Timer Application.ScreenUpdating = False MyFindText = Array("计算日期:", "界址点数:") For Each aText In MyFindText Set MyFindRange = ThisDocument.Content With MyFindRange.Find .ClearFormatting Do While .Execute(findtext:=aText & vbTab) Set MyRange = MyFindRange.Paragraphs(1).Range With MyRange '去除所有该段落中的制表位 .Text = VBA.Replace(MyRange, vbTab, "") '在文档的8厘米处增加一个制表位 .Paragraphs.TabStops.Add Position:=Word.CentimetersToPoints(8) Pos = VBA.InStr(.Text, aText) '取得指定的文本所在位置的RANGE对象 Set MyRange = ThisDocument.Range(.Start + Pos - 1, .Start + Pos - 1) MyRange.InsertAfter vbTab End With '插入一个TAB键(移至指定制表位) Loop End With Next Application.ScreenUpdating = True ' Debug.Print Timer End Sub '---------------------

firewzy

谢谢守柔！