WORD VBA 改變字距

word vba 巨集

hahahacja 2010-04-09 11:10:38 ‧ 11226 瀏覽

分享至

您好
我有一WORD檔 ,表格內(用虛線代替)有公司名 + TEL + 地址, 格子寬度只能200寬,
因有些地址長度太長,如下面的[ADRS].....[ADRE] (超過表格寬度),目前都是用手動
將文字反白然後改變字距,讓地址長度縮小,讓地址在表格中都在同一行,
目前有用巨集+快速鍵,但都只能一筆一筆處理,很慢.
請問如何利用VBA巨集,一次就可以把所有[ADRS].....[ADRE]的範為做字距改變?
謝謝!

某A企業有限公司
111桃園縣1111111號
Tel.03-11111111

某B企業有限公司
222[ADRS]桃園縣222222222222號[ADRE]
Tel.03-22222

某C企業有限公司
222[ADRS]桃園縣1111111號[ADRE]
Tel.03-22222

某D企業有限公司
222桃園縣1111111號
Tel.03-22222

某B企業有限公司
222[ADRS]桃園縣1111111號[ADRE]
Tel.03-22222

看更多先前的討論...收起先前的討論...

hahahacja iT邦新手 5 級 ‧ 2010-04-09 23:21:18 檢舉

這是我的方式,人生第一支VBA,請各位指導一下

Sub 巨集1111()
Dim parag As Paragraph
Dim i, nLineNum, total As Integer
nLineNum = 0
total = 0
For Each parag In ActiveDocument.Paragraphs
nLineNum = nLineNum + 1
parag.Range.Select
sText = Selection.Text
i = InStr(sText, "ADRS")
If i > 0 Then
total = total + 1
e = InStr(sText, "ADRE")
sText_len = e - (i + 4)
'MsgBox i & "--" & e
sText2 = Mid(sText, i + 4, sText_len)

Selection.HomeKey Unit:=wdLine '跳到每格的第一個字
Selection.MoveRight Unit:=wdCharacter, Count:=i - 1
'移到ADRS的A字
Selection.Delete Unit:=wdCharacter, Count:=1 '刪A
Selection.Delete Unit:=wdCharacter, Count:=1 '刪D
Selection.Delete Unit:=wdCharacter, Count:=1 '刪R
Selection.Delete Unit:=wdCharacter, Count:=1 '刪S

後部份在下一則.....

hahahacja iT邦新手 5 級 ‧ 2010-04-09 23:21:57 檢舉

'移道ADRE前算選取地址
Selection.MoveRight Unit:=wdCharacter, Count:=sText_len, Extend:=wdExtend
'判地址字數來算要所縮小多少字距
If sText_len < 18 Then
Scaling_num = 100
Else
Scaling_num = 90 - (sText_len - 18) * 3
End If

後部份在下一則.....

hahahacja iT邦新手 5 級 ‧ 2010-04-09 23:22:48 檢舉

With Selection.Font
.NameFarEast = "細明體"
.NameAscii = "細明體"
.NameOther = "細明體"
.Name = "細明體"
.Size = 9
.Bold = False
.Italic = False
.Underline = wdUnderlineNone
.UnderlineColor = wdColorAutomatic
.StrikeThrough = False
.DoubleStrikeThrough = False
.Outline = False
.Emboss = False
.Shadow = False
.Hidden = False
.SmallCaps = False
.AllCaps = False
.Color = wdColorAutomatic
.Engrave = False
後部份在下一則.....

hahahacja iT邦新手 5 級 ‧ 2010-04-09 23:24:01 檢舉

.Superscript = False
.Subscript = False
.Spacing = 0
.Scaling = Scaling_num
.Position = 0
.Kerning = 1
.Animation = wdAnimationNone
.DisableCharacterSpaceGrid = False
.EmphasisMark = wdEmphasisMarkNone
End With
Selection.MoveRight Unit:=wdCharacter, Count:=1 '移一格
Selection.Delete Unit:=wdCharacter, Count:=1 '刪A
Selection.Delete Unit:=wdCharacter, Count:=1 '刪D
Selection.Delete Unit:=wdCharacter, Count:=1 '刪R
Selection.Delete Unit:=wdCharacter, Count:=1 '刪e
End If
Next
If total > 0 Then
MsgBox "總計找到 " & total & " 個地址!!"
End If
End Sub

---end----

登入發表討論

直播研討會

{{ item.channelVendor }} {{ item.webinarstarted }} |

直播中

1 個回答

海綿寶寶

iT邦大神 1 級 ‧ 2010-04-09 14:09:25

最佳解答

試試看
執行時游標要在文件最前(上)面

&lt;pre class="c" name="code">
Sub iTHelpIsGood()
'
    '--搜尋 [ADRS] 字串
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "[ADRS]"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .MatchFuzzy = False
    End With
    '--如果找得到的話, 就將字體間距縮小
    '--如果找不到的話, 就結束執行
    Do While Selection.Find.Execute
        Selection.EndKey Unit:=wdLine, Extend:=wdExtend
        With Selection.Font
            .NameFarEast = "新細明體"
            .NameAscii = "Times New Roman"
            .NameOther = "Times New Roman"
            .Name = ""
            .Size = 12
            .Bold = False
            .Italic = False
            .Underline = wdUnderlineNone
            .UnderlineColor = wdColorAutomatic
            .StrikeThrough = False
            .DoubleStrikeThrough = False
            .Outline = False
            .Emboss = False
            .Shadow = False
            .Hidden = False
            .SmallCaps = False
            .AllCaps = False
            .Color = wdColorAutomatic
            .Engrave = False
            .Superscript = False
            .Subscript = False
            .Spacing = -1
            .Scaling = 100
            .Position = 0
            .Kerning = 1
            .Animation = wdAnimationNone
            .DisableCharacterSpaceGrid = False
            .EmphasisMark = wdEmphasisMarkNone
        End With
        Selection.MoveDown Unit:=wdLine, Count:=1
    Loop
End Sub

回應 1
分享
檢舉

hahahacja iT邦新手 5 級 ‧ 2010-04-09 23:26:05 檢舉

謝謝!

登入發表回應

我要發表回答

立即登入回答

參賽組數

1064 組

團體組數

40 組

累計文章數

22207 篇

完賽人數

600 人

15th鐵人賽 16th鐵人賽 13th鐵人賽 14th鐵人賽 12th鐵人賽 11th鐵人賽鐵人賽 2019鐵人賽 javascript 2018鐵人賽 python 2017鐵人賽 windows php c# windows server linux css react vue.js

IT邦幫忙