Word作成の置換マクロをEXCELでも使用したい。

質問

Wordで作成した置換マクロをEXCELでも使用する方法を教えてください。

WordのマクロをエクスポートしてEXCELでインポートしましたが
うまく動きません。
同じofficeなのに対応はしていないのでしょうか？？

回答No.3

Wendy02 · ベストアンサー

こんにちは。

#1の補足のマクロは、たぶん、私の書いたものだと思いますが、前回と同じく、ご自身で作っていない場合は、他の人が書いた旨を書いていただいたほうがよいですね。そうしないと、マクロが出来ると勘違いされ、話がちぐはぐになってしまいます。一応、Excel版も掲示板に残しておきます。

正規表現のパターン　の場所のそれぞれに、半角対象、全角対象の中に、Unicode の範囲の文字を入れるだけでよいです。なお、半角カタカナは、インターネット上で、半角カタカナが書けないために、便宜的に文字コードで入れているだけですから、実際にお使いの際は、半角カタカナでもかまいません。

ただし、特殊な記号の置換に関しては、ご自身で出来ないとは言いませんが、私のコードからでは、少し手間が多くなります。例　[1] -> (1)

単純なものなら、記録マクロでも良いかもしれません。

---------------------------------
'標準モジュール

Sub RegReplacement()
　　'半角カタカナを全角に、全角英数を半角にするマクロ　(Excel編）
　　Dim rng As Range
　　Dim Re As Object
　　Dim myPat As String
　　Dim c As Range
　　Dim Matches As Object
　　Dim Match As Object
　　Dim Str1 As String
　　Dim Str2 As String
　　Dim buf As String
　　Dim t As Long
　　On Error Resume Next
　　Set rng = ActiveSheet.UsedRange.SpecialCells _
　　(xlCellTypeConstants, xlTextValues)
　　On Error GoTo 0
　　If rng Is Nothing Then
　　　　MsgBox "変換する対象が見当たりません。", 48
　　　　Exit Sub
　　End If
　　'全角側　---　半角側 (！-／ を加えれば記号も半角)
　　myPat = "([\uFF66-\uFF9F]*)([０-９Ａ-ｚ]*)" '正規表現のパターン
　　Set Re = CreateObject("VBScript.RegExp")
　　Application.ScreenUpdating = False
　　With Re
　　　　.Global = True
　　　　.IgnoreCase = True
　　　　.Pattern = myPat
　　　　For Each c In rng.Cells
　　　　　　Set Matches = .Execute(c.Value)
　　　　　　If Matches.Count > 0 Then
　　　　　　　　buf = c.Value
　　　　　　　　For Each Match In Matches
　　　　　　　　　　If Len(Match.Value) > 0 Then
　　　　　　　　　　　　Str1 = StrConv(Match.SubMatches(0), vbWide)
　　　　　　　　　　　　If Str1 <> "" Then
　　　　　　　　　　　　　　'0 =vbBinaryCompare
　　　　　　　　　　　　　　buf = Replace(buf, Match.SubMatches(0), Str1, , , 0)
　　　　　　　　　　　　End If
　　　　　　　　　　　　Str2 = StrConv(Match.SubMatches(1), vbNarrow)
　　　　　　　　　　　　If Str2 <> "" Then
　　　　　　　　　　　　　　buf = Replace(buf, Match.SubMatches(1), Str2, , , 0)
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　　　　　Str1 = "": Str2 = ""
　　　　　　　　Next Match
　　　　　　　　If buf <> c.Value Then
　　　　　　　　　　c.Value = buf
　　　　　　　　　　t = t + 1
　　　　　　　　End If
　　　　　　End If
　　　　Next c
　　End With
　　Set Re = Nothing
　　Application.ScreenUpdating = True
　　If t > 0 Then
　　　　MsgBox t & "個のセルを変換しました。", 64
　　End If
End Sub

お礼

いつもすいません。。
(_ _(--;(_ _(--; ペコペコ

記号は半角にしたいです。
どの行と置き換えればいいですか？？

回答No.5

Wendy02

こんばんは。

先ほど、同様のマクロ(記号も含めたもの）を書きましたので、

「QNo.4086577 ＥＸＣＥＬ　「ＡＳＣ」関数　　英数字の全角を半角に変換するよい方法があれば教えてください 」

http://oshiete1.goo.ne.jp/qa4086577.html

こちらのほうも、一読ください。

回答No.4

Wendy02

こんにちは。

>記号は半角にしたいです。
>どの行と置き換えればいいですか？？

Wordよりも簡単ですから、非常に有効なコツを教えておきます。

-----------------------------------
　'全角側　---　半角側 (！-／ を加えれば記号も半角)
>myPat = "([\uFF66-\uFF9F]*)([０-９Ａ-ｚ]*)" '正規表現のパターン
　　↓

myPat = "([\uFF66-\uFF9F]*)([！-／０-９Ａ-ｚ]*)" '正規表現のパターン

または、

myPat = "([\uFF66-\uFF9F]*)([！-｝]*)" '正規表現のパターン

-----------------------------------
とすれば、！-／ の間を含めたものはすべて含みます、という意味です。！-｝の場合は、その範囲すべてです。(連結の'-' は、必ず半角です）

この並びは、Unicode の並びです。MS-IME のIMEパッドの文字一覧を出して、上の窓の左側に、シフトJISとか、Unicode と出ているはずですから、Unicode にします。右側の窓には、MSゴシックとか、MS明朝とかします。そして、左隣の窓の「半角形/全角形」を選んで、その範囲を、半角の「-」で結べば、そのすべてを含めます、という意味になります。「０-９」は、全角の０から９まで、ということです。

実は、Wordでも、同じことが出来るのですが、Wordの場合は、必ずしも、そういう方式が良いとは限らないので、こういう方法を選ばなかったのです。

ただ、個々の全角→半角ではない場合は、Replace で個々に置き換えてあげる方法が一番楽かもしれません。

回答No.2

KenKen_SP

こんにちは。

Word / Excel の VBA は、基本的な部分で共通ですが、多くのケースで
そのままでは動きません。

適当に書いたものですが、下記のコードが参考になれば。。。

余談ですが、電子納品において記号の扱いはどうなのでしょうか？
また、テキストボックス内等のテキストは検索対象外になってますので、
ご注意を。

Sub SampleProc()

　　' // 正規表現によりマッチした部分の全角・半角置換

　　Dim reg　　　　As Object ' // RegExp
　　Dim regMatch　 As Object ' // Match
　　Dim rTarget　　As Range
　　Dim r　　　　　As Range
　　Dim s　　　　　As String
　　Dim i　　　　　As Long
　　Dim vPatterns　As Variant
　　Dim vConverts　As Variant

　　' // Matching Pattern 定義 --------------------------------------
　　vPatterns = Array("[" & Chr("&HA6") & "-" & Chr("&HDF") & "]+", _
　　　　　　　　　　　"[０-９]+", _
　　　　　　　　　　　"[Ａ-ｚ]")
　　' // Conversion 定義（必ず Pattern と対応させる）-----------------
　　vConverts = Array(vbWide, _
　　　　　　　　　　　vbNarrow, _
　　　　　　　　　　　vbNarrow)

　　' // 処理対象範囲を取得（定数のセルのみを扱う）
　　' // 23: All Value Type
　　Set rTarget = Cells.SpecialCells(xlCellTypeConstants, 23)
　　If rTarget Is Nothing Then
　　　　MsgBox "置換対象はありません", vbInformation
　　　　Exit Sub
　　End If

　　Application.ScreenUpdating = False
　　Set reg = CreateObject("VBScript.RegExp")
　　For Each r In rTarget.Cells
　　　　s = r.Value
　　　　For i = 0 To UBound(vPatterns)
　　　　　　reg.Pattern = vPatterns(i)
　　　　　　reg.Global = True
　　　　　　For Each regMatch In reg.Execute(s)
　　　　　　　　s = Replace$(s, regMatch, _
　　　　　　　　　　StrConv(regMatch, vConverts(i)))
　　　　　　Next
　　　　Next
　　　　r.Value = s
　　Next r

　　Set reg = Nothing
　　Set rTarget = Nothing

End Sub

回答No.1

marbin

そのままでは使えないと思います。

コードを↓にアップしてみてください。

補足

了解です。
宜しくお願いします。

Sub 電子納品禁止文字置換()
Dim buf As String
Dim t As Integer
Dim myMsg As String
Dim FChr As String
Dim LChr As String

Selection.HomeKey Unit:=wdStory '文書の先頭に
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

End Sub