いらっしゃいませ、230790番目のお客様。  

[Word]実用(?)マクロ集

このページに含まれるプログラム、ファイル等については、

  1. 一応、著作権は放棄してません。転載等される方は私にご連絡ください。
  2. 内容については万全を期していますが、利用については自己責任でお願いします。いかなる損害にも責任を負いません。
  3. 動作確認は、(1)Windows 98+Excel 2000; (2)Windows XP+Excel 2002で行っています。
以上の点にご注意願います。


目次

  1. フィールドあれこれ
  2. 記録位置へのジャンプ
  3. マクロによる単語の入力
  4. 蛍光ペン付き文字の検索
  5. 行数を数える
  6. 文章をつなげる

Office VBAの部屋に戻る

フィールドあれこれ(2002/5/11)

Wordでは自動更新するテキストとしてフィールドを設定することが出来ます。例えば、総ページ数や現在の時刻を常に更新した形でテキストに記述することが出来ます。
ただ、「文章作成日」は書いてるときには更新されるほうが便利ですが、最終稿を仕上げた後に印刷するたびに日付が変わっていくのは困りますし、総ページ数は開くたびになぜか「1」に戻ってしまう不都合が生じたりします。というわけで、書き込み終了後のフィールドを通常のテキストに変換するプチプログラムです。

プログラム

Public Sub FieldUnlink()
    Selection.Fields.Unlink
End Sub

解除(テキストへ変換)したいフィールドを含む文章を選択してから実行してください。単にフィールドを(更新されないように)ロックするならSelection.Fields.Locked = Trueでもかまいません。
一方、今から挿入するフィールドを初めからテキストに変換したいとき、次のプログラムが有効です。

プログラム2

Private Sub AddFieldAsConst(Field As String)
    With Selection
        .Fields.Add(Range:=.Range, Type:=wdFieldEmpty, Text:=Field).Unlink
    End With
End Sub

Public Sub AddNumPages()
    AddFieldAsConst "NUMPAGES  "
End Sub

Public Sub AddTime()
    AddFieldAsConst "TIME  \@ ""AMPMh時m分s秒"" "
End Sub

やっている事は前のプログラムと変わりません。ただ、挿入したフィールドのみを解除するようにしてあります。最初の関数をわかりやすく書くと、

プログラム3

Private Sub AddFieldAsConst(Field As String)
    Dim NewField As Field
    Set NewField = Selection.Fields.Add(Range:=Selection.Range, Type:=wdFieldEmpty, Text:=Field)
    NewField.Unlink
End Sub

となります。フィールドの挿入方法はプログラム3の3行目が一般的でしょう。このプログラムでは汎用性を持たすために、TypeにwdFieldEmptyを指定し、通常のWordのフィールド指定と同じ命令をField変数に渡してもらい、それをTextに渡すことによって、フィールドを作成しています。これ以外にTypeに特定の定数(フィールドの種類だけあります。)を渡して、フィールドスイッチのみをTextに記述するという方法も使うことが出来ます。


目次に戻る

記録位置へのジャンプ(2002/5/18)

ワードで文章の中で何箇所かを行き来したい場合があります。そんな時役に立つのが次のプログラムです。RecordRangeStackで記録した場所にSeekRangeStackで飛んで、いらなくなった記録位置はDeleteRangeStackで消去するという手順になると思います。ボタンで登録すると便利でしょう。

プログラム

Option Explicit
Option Base 1

Private Const MAX As Integer = 255  '記録できる最大量
Private RangeStack(MAX) As Range    '記録のための配列
Private seekNo As Integer           '直前にジャンプした記録番号
Private num As Integer              '記録数

'位置の記録。最終の記録番号の後に追加されます。
Public Sub RecordRangeStack()
    If num >= MAX Then              '記録数確認
        MsgBox "記録することが出来ません。", vbOKOnly, "記録容量オーバー"
    Else
        num = num + 1               '記録数の増加
        seekNo = 0                  'ジャンプ位置の初期化。次回、ジャンプするときは
                                    '直前に記録したところにジャンプします。
        Set RangeStack(num) = Selection.Range   '位置の記録
    End If
End Sub

'位置記録の消去。直前にジャンプした記録番号を消去し、
'番号をつめます。
Public Sub DeleteRangeStack()
    Dim i As Integer
    If num <= 0 Then                '記録の有無のチェック
        MsgBox "記録がありません。", vbOKOnly, "記録なし"
    Else
        If seekNo < num Then
            '直前にジャンプした番号に+1の番号に記録した位置をコピーします。
            'これを最後の記録-1まですることによって、記録が1つ減ることになります。
            For i = seekNo To num - 1
                Set RangeStack(i) = RangeStack(i + 1)
            Next i
        End If
        Set RangeStack(num) = Nothing   '最終記録位置の消去
        num = num - 1                   '記録数の減少
    End If
End Sub

'位置記録へのジャンプ。新しい記録から徐々に古い記録までジャンプします。
Public Sub SeekRangeStack()
    If num <= 0 Then                '記録の有無のチェック
        MsgBox "記録がありません。", vbOKOnly, "記録なし"
    Else
        seekNo = seekNo - 1         '一つ古い記録へ移動
        If seekNo < 1 Then seekNo = num '1より小さい(1番目へのジャンプの後)なら、
                                        '最新記録位置へ移動
        RangeStack(seekNo).Select       '記録位置の選択
    End If
End Sub

WordでVBAはNormalプロジェクトに記録する方法と文書ごとに記録する方法があります。ワードの操作に関してはNormalプロジェクトに登録するほうが便利でしょう。

ちなみに、直前の編集位置へ戻るだけなら、Shift+F5で戻れます。(5個前まで)


目次に戻る

マクロによる単語の入力(2002/6/28)

決まった単語を入力するのにその単語をマクロを使って貼り付けている人はいますか?普通の入力でもそうなのですが、その単語が下付きとか上付きとかで終わる場合は、次の入力文字がその書式の影響を受けてしまいます。また、せっかくマクロで作って入力したのに選択範囲の書式を受け継いでしまい、希望と異なるフォント(下線等も含めて)で入力されてしまうことがあると思います。そこで、貼り付け前のフォントの書式に従わず、貼り付け後の入力を貼り付け前の書式に従わせるマクロと言うのを作りました。

プログラム

Sub CO2()
    Const Text As String = "CO2"
    Const Dummy As String = "e"
    Const LenDummy As Integer = 1
    Dim LenText As Long, r As Range
    LenText = Len(Text)
    Application.ScreenUpdating = False
    With Selection
        .TypeText Text & Dummy
        .MoveLeft wdCharacter, LenText + LenDummy, wdExtend
        ActiveDocument.Range(.Start, .End - LenDummy).Font.Reset '元の書式を生かす場合は不要
        .Characters(3).Font.Subscript = True
        .Collapse wdCollapseEnd
        .TypeBackspace
    End With
    Application.ScreenUpdating = True
End Sub

同じ作法でどんどんワンキーで入力できるマクロが出来ると思います。使いやすさ向上のためにもどんどん作ってみましょう。


目次に戻る

蛍光ペン付き文字の検索(2002/7/2)

今回は、VBAプログラムを駆使すればワード(エクセルでもそうですが)の機能を知らなくても用を足す事は出来る。でも、知っていればずっと楽。という話(実話)です。

「変更点に蛍光ペンで色を付けているので、チェックしてください。」と言う何十ページにもおよぶファイルが届きました。おいおい、と思いながら、ページスクロールをするのですが、全部チェックできたのかどうかわからない。で、一つずつチェックするプログラムを作りました。

プログラム1

Sub ColorCheck()
    Dim bgc As Word.WdColorIndex
    Application.ScreenUpdating = False
    Selection.Collapse wdCollapseStart
    Do While Selection.Range.HighlightColorIndex = wdNoHighlight
        Selection.MoveRight wdCharacter, 1, wdMove
    Loop
    Application.ScreenUpdating = True
End Sub

プログラムの内容は選択範囲の初めから、1文字ずつ色がついているかどうかチェックして、色のついているところで処理を終わると言うものです。実に普通の考え方ですが、ひたすら遅い。で、2分割法(と言うのが正しいのかどうか知りませんが)でチェックする方法を考えました。

プログラム2

Sub ColorCheck2()
    Dim check As Boolean, col As WdColorIndex
    Application.ScreenUpdating = False
    Selection.Collapse wdCollapseStart
    Selection.MoveRight wdCharacter, 1, wdExtend
    col = Selection.Range.HighlightColorIndex
    If col <> wdNoHighlight Then            '既に色がついている部分ならとばす。
        Selection.EndKey wdStory, wdExtend
        SubColorCheck Selection.Range, col
    End If
    Selection.EndKey wdStory, wdExtend
    check = SubColorCheck(Selection.Range)
    Selection.Collapse wdCollapseStart
    Application.ScreenUpdating = True
    If check = False Then MsgBox "見つかりませんでした。"   '見つからなかったときの処理
End Sub

Private Function SubColorCheck(r As Range, Optional DefaultColor As WdColorIndex = wdNoHighlight) As Boolean
    Const MultipleColor As Long = 9999999
    Dim Center As Long
    Dim col As WdColorIndex
    col = r.HighlightColorIndex
    If col = MultipleColor Then     '色付き/無しの部分を両方含む場合
        With r
            Center = Round((.Start + .End) / 2) '範囲を2つに分けてさらに検索を実施
            If SubColorCheck(ActiveDocument.Range(.Start, Center), DefaultColor) Then
                SubColorCheck = True    '前半にあった場合
            Else    '前半になかった場合は後半についても処理を行う。
                SubColorCheck = SubColorCheck(ActiveDocument.Range(Center, .End), DefaultColor)
            End If
        End With
    Else
        If col = DefaultColor Then  '色無し(指定色)の部分のみ含む場合
            SubColorCheck = False
        Else                        '色付き(指定色以外)の部分のみ含む場合
            r.Select
            SubColorCheck = True    '見つかったので、全ての処理が終了される。
        End If
    End If
End Function

以前紹介した再帰呼び出しを使っています。無限ループ(いつまでたっても処理が終わらないこと)にならないように注意しています。このマクロをボタン登録しておけば、ポンポンポンと押すだけで、次々、新しい蛍光ペンの部分に飛んでいくわけです。これで万事解決!

…なのですが、Wordのヘルプを見ると蛍光ペンの検索が検索パネルで出来るではないですか。で、お決まりの「新しいマクロの記録」をした結果、次のようなプログラムが出来ることがわかりました。

プログラム3

Sub ColorCheck3()
    With Selection.Find
        .ClearFormatting
        .Highlight = True
        .Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = True
    End With
    Selection.Find.Execute
End Sub

なんて簡単、そしてなんて高速!前のプログラムにかけた30分を返して欲しい(苦笑)。ただ、このプログラムでは蛍光ペンは一緒くたにされるので、違う色でチェックしてもまとめて検索されてしまいます(プログラム2ではそんな事はありません)。別々に気がつくほうがいいと言う方はぜひともプログラム2を使ってください(涙)。

結論と言うか教訓ですが、「簡便で効率的なプログラムを作るためにはアプリケーションの機能に詳しくなければならない」ということです。


目次に戻る

行数を数える(2002/7/19)

必要に迫られて、VBAで行数を数えようと思いましたが、適当なプロパティが見つかりませんでした。例によって無理やりVBAで勘定しています。もっといい方法を知っている方は教えてください。
ちなみに普通に知ろうと思えば、ファイル(F)→プロパティ(I)の詳細情報で知ることが出来ます。(最終行が0文字(リターンコードのみ)の場合はカウントされません。)

プログラム

Function LineCount() As Long
    Const MaxLong As Long = 2147483647
    Dim now As Range
    Dim l As Long
    Set now = Selection.Range
    Application.ScreenUpdating = False
    ActiveDocument.Range(0, 0).Select
    l = Selection.MoveDown(wdLine, MaxLong, wdMove)
    now.Select
    Application.ScreenUpdating = True
    LineCount = l + 1
End Function

Sub 行数()
    MsgBox LineCount & " 行です。"
End Sub

このプログラムは最終行が0文字でもカウントしてしまいます。今回の場合はそのほうが都合がいいので、そのままになっています。


目次に戻る

文章をつなげる(2002/8/31)

参加者全員の報告書を一度にコピーしたりする場合に、2面印刷や両面印刷がしたいなぁとか全部いっぺんに印刷処理したくなる場合がありますよね。印刷処理に限らず、読み込んだ文章をすべてつなげて保存したいことがあると思います。そんなときに手作業でやっていたことを自動で行うプログラムです。

プログラム

Sub MergeFile(Optional dummy As Integer = 0)
    Dim d As Document, nDoc As Document
    Dim s As Range
    Set nDoc = Documents.Add
    For Each d In Documents
        If Not d Is nDoc Then
            Set s = nDoc.Content
            s.Collapse Direction:=wdCollapseEnd
            s.InsertBreak wdSectionBreakNextPage
            d.Range.Copy
            Set s = nDoc.Content
            s.Collapse Direction:=wdCollapseEnd
            s.Paste
        End If
    Next d
    Selection.Delete
End Sub

若干の書式の差には対応できていると思いますが、手作業で難しい処理(1枚で印刷できるはずのものが2ページにわたるなどの改ページ処理)などには対応できていません。


目次に戻る

にゃま夫のへや   ・Office VBA   ・おもちゃ箱   ・iαppli
ホームページに戻る。
無断転載を禁じます。
にゃま夫