Wordのマクロを造りたいです。

質問

マクロの条件は以下のとおりです。

カタカナ⇒全角
英数字記号⇒半角

別途指定文字の変換
(例)　　　(1)⇒[1]

変換文字個数を表示

上記、4つの内容を1つのマクロ内で処理したいです。
お知恵をお願いします。

現在使用しているのは以下のマクロです。
Sub 電子納品のための変換プログラム()
'
' 電子納品のための変換プログラム Macro
' 記録日 2006/01/19 記録者 HP Customer
'
With Selection.Find
.MatchFuzzy = False
End With

t = 0
' 英字
While Selection.Find.Execute(FindText:="[Ａ-ｚ]", _
Wrap:=wdFindContinue, MatchWildcards:=True) = True
Forward = True
MatchWildcards = True
Selection.Range.CharacterWidth = wdWidthHalfWidth
t = t + 1
Wend

' 数字
While Selection.Find.Execute(FindText:="[０-９]", _
Wrap:=wdFindContinue, MatchWildcards:=True) = True
Forward = True
MatchWildcards = True
Selection.Range.CharacterWidth = wdWidthHalfWidth
t = t + 1
Wend

' カナ文字
While Selection.Find.Execute(FindText:="[ヲ-ン][゛゜]", _
Wrap:=wdFindContinue, MatchWildcards:=True) = True
MatchWildcards = True
Selection.Range.CharacterWidth = wdWidthFullWidth
t = t + 1
Wend

While Selection.Find.Execute(FindText:="[ヲ-ン]", _
Wrap:=wdFindContinue, MatchWildcards:=True) = True
MatchWildcards = True
Selection.Range.CharacterWidth = wdWidthFullWidth
t = t + 1
Wend

While Selection.Find.Execute(FindText:="［。-゜］", _
Wrap:=wdFindContinue, MatchWildcards:=True) = True
MatchWildcards = True
Selection.Range.CharacterWidth = wdWidthFullWidth
t = t + 1
Wend

t = CStr(t)

Msg = t + "件の変換がありました。"

MsgBox (Msg)
End Sub

回答No.2

Wendy02 · ベストアンサー

こんばんは。

Sub HankakuZenkaku()　の作者です。

一応、元の文章にも書かれてありますが、

>'半角カタカナ
>FChr = Chr("&HA6")　'半角ヲ
>LChr = Chr("&HDF") '半角゜

の部分は、掲示板上、半角カタカナを書き出せないので、書いているまでですから、半角カタカナのままお使いになってよいです。

別途指定文字の変換
(例)　　　(1)⇒[1]

以下のようなものを、最後の部分に付け加えてください。本来は、正規表現を使えばよいのですが、全体の調子が変わりますので、このようなものにしました。ただし、Wordの一般　Document 上しかためしていません。Wordには、このほかにも、OLEのTextBox やField やAutoShape など、さまざまなものがありますから、うまく行かない場合は、再び考えていくしかないと思います。Sample自体は、ここの掲示板を検索すれば、私のコードが出てきます。

---------------------------------------

Dim buf As String '付け加える
'指定語
While .Execute(FindText:="\([0-9]{1,}\)", _
　　Wrap:=wdFindContinue, MatchWildcards:=True) = True
　　buf = Selection.Range.Text
　　buf = Replace(buf, "(", "[", , , 1)
　　buf = Replace(buf, ")", "]", , , 1)
　　Selection.Range.Text = buf
　　Selection.Range.Collapse Direction:=wdCollapseEnd
　　buf = ""
　　t = t + 1
Wend

---------------------------------------
変換文字個数を表示

この問題は、色を加えていくとか、最初に選択をしておいて一気に換えてしまうという方法がよいのですが、逐次で、変換していくために、もし、そのようにするには、全面的なコードを変更しなければならないと思います。出来れば、そのままでお使い願いたいです。

なお、Wordの検索・置換マクロは、

>With Selection.Find
>.MatchFuzzy = False
>End With

このように、一部ではなく、必ず、すべてを初期化してから実施するようにしてください。誤動作することが多いです。

お礼

すいません…
全くの初心者なので良く解らないのですが戴いたプログラムを追記しただけでは動きませんでした。

プログラムの始めから終わりまで教えてもらえませんか？

回答No.4

Wendy02

こんばんは。

>(1)
>↓
>[1]
>へ置き換える場合は以下のようにすればよいですか？

私の書いたマクロではダメだったということでしょうか。#3のお礼の内容は、コードとしてこちらが提示したものとは、まったく違いますので、なんともお答えのしようがありません。こちらの回答の範囲外になってしまいます。

おそらくは、#3のお礼で書いたものは、記録マクロだと思いますが、その良否の判定は出来ませんが、

(1)
↓
[1]

ということで、置換のプロパティのデフォルト状態が守れるなら、それで可能だと思います。記録マクロでは、その状態が確保できませんので、マクロの結果が不安定になります。また、Wordのヘルプに書かれてあるワイルドカードを参考になさってもよいと思います。

それに、あくまで、他人のコードでなく、ご自身のスタイルでマクロをお書きになりしたいのでしたら、最初に、その旨をおっしゃっていただいたほうが良いと思います。私は、以下のサイトで勉強しました。

http://word.mvps.org/FAQs/MacrosVBA/index.htm

英語ですが、Wordのマクロを集めたサイトです。日本語の２バイトのサポートがないので、それだけは、なかなか参りました。

お礼

ありがとうございます。
頑張って見ます。

回答No.3

Wendy02

こんばんは。

>全くの初心者なので良く解らないのですが戴いたプログラムを追記しただけでは動きませんでした。

質問の元のコードは、記録マクロでは出来ないはずだと思いましたので、必要な部分だけを書きました。

指定語の
Selection.Range.Collapse Direction:=wdCollapseEnd
は、きちんとヒットしていれば、必要ありませんが、これがないと、無限ループに陥る可能性があります。

コードの置き場所は、ThisDocument もしくは、標準モジュールです。
'---------------------------------------------------

Sub HankakuZenkaku2()
Dim buf As String
Dim t As Integer
Dim myMsg As String
Dim FChr As String
Dim LChr As String

Selection.HomeKey Unit:=wdStory '文書の先頭に
On Error GoTo Errmsg:
With Selection.Find
　　.ClearFormatting
　　.Text = ""
　　.Replacement.Text = ""
　　.MatchFuzzy = False

'半角カタカナ
FChr = Chr("&HA6")　'半角ヲ
LChr = Chr("&HDF") '半角゜
While .Execute(FindText:="[" & FChr & "-" & LChr & "]{1,}", _
　　Wrap:=wdFindContinue, MatchWildcards:=True) = True
　　Selection.Range.CharacterWidth = wdWidthFullWidth
　　t = t + 1
Wend

'数字
While .Execute(FindText:="[０-９]{1,}", _
　　Wrap:=wdFindContinue, MatchWildcards:=True) = True
　　Selection.Range.CharacterWidth = wdWidthHalfWidth '半角
　　t = t + 1
Wend
'アルファベット
While .Execute(FindText:="[Ａ-ｚ]{1,}", _
　　Wrap:=wdFindContinue, MatchWildcards:=True) = True
　　Selection.Range.CharacterWidth = wdWidthHalfWidth
　　t = t + 1
Wend

'指定語
While .Execute(FindText:="\([0-9]{1,}\)", _
　　Wrap:=wdFindContinue, MatchWildcards:=True) = True
　　buf = Selection.Range.Text
　　buf = Replace(buf, "(", "[", , , 1)
　　buf = Replace(buf, ")", "]", , , 1)
　　Selection.Range.Text = buf
　　Selection.Range.Collapse Direction:=wdCollapseEnd
　　buf = ""
　　t = t + 1
Wend
　　 Selection.HomeKey Unit:=wdStory　'文書の先頭に
　　 If t > 0 Then
　　　　myMsg = t & "語、変換しました。"
　　 Else
　　　　myMsg = "変換するべき文字はありませんでした。"
　　 End If
　　 MsgBox myMsg, vbInformation
End With
　　Exit Sub
Errmsg:
　 MsgBox "エラー!: " & Err.Description, vbExclamation
End Sub

お礼

ありがとうございます。
早速使用したのですが指定語のところで
例えば
(1)
↓
[1]
へ置き換える場合は以下のようにすればよいですか？

'指定語
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "(1)"
.Replacement.Text = "[1]"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub

回答No.1

enunokokoro

こちら↓の過去ログが参考になるのでは

半角カナは全角カナに、全角英数字は半角英数字に、一気に置換したい
http://oshiete1.goo.ne.jp/qa3283357.html