統合セルのマクロ処理について

質問

お世話になっております。

現在マクロにて選択した範囲のセルにおいて
半角・全角・単語の書式を統一する処理をおこなっていますが、
統合されたセルが入ってくるととたんに処理に時間がかかってしまいます。
（対象となるシートの書式はさまざまです。）

なんとか解消したいのですが、ご教示お願いできませんでしょうか？

以下マクロになります。

すみませんが、なにとぞよろしくお願い致します。

Sub 書式定義Macro()

Dim c As Range
Dim myStr As String
Dim Match As Object, Matches As Object

With CreateObject("VBScript.RegExp")
.Pattern = "[\uFF61-\uFF9F]+" '---(1)
.Global = True

For Each c In Selection
myStr = c.Value
If Len(myStr) > 0 Then
Set Matches = .Execute(myStr)

'マッチしたすべての文字列を全角へ置換
For Each Match In Matches
myStr = Replace(myStr, Match.Value, _
StrConv(Match.Value, vbWide)) '---(2)
Next Match
c.Value = myStr
End If
Next c
End With

With CreateObject("VBScript.RegExp")
.Pattern = "[０-９]+" '---(1)
.Global = True

For Each c In Selection
myStr = c.Value
If Len(myStr) > 0 Then
Set Matches = .Execute(myStr)

'マッチしたすべての文字列を半角へ置換
For Each Match In Matches
myStr = Replace(myStr, Match.Value, _
StrConv(Match.Value, vbNarrow)) '---(2)
Next Match

c.Value = myStr
End If
Next c
End With

With CreateObject("VBScript.RegExp")
.Pattern = "[\uFF20-\uFF60]+" '---(1)
.Global = True

For Each c In Selection
myStr = c.Value
If Len(myStr) > 0 Then
Set Matches = .Execute(myStr)

'マッチしたすべての文字列を半角へ置換
For Each Match In Matches
myStr = Replace(myStr, Match.Value, _
StrConv(Match.Value, vbNarrow)) '---(2)
Next Match
c.Value = myStr
End If
Next c
End With

Dim r As Range

'ここの処理が統合セルの処理の際重くなる。

For Each r In Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)

r.Value = Replace(r.Value, "デジカメ", "デジタルカメラ")
r.Value = Replace(r.Value, "携帯", "携帯電話")
r.Value = Replace(r.Value, "仮開通試験", "")
r.Value = Replace(r.Value, "入管", "入館")
r.Value = Replace(r.Value, "センタ", "センター")
r.Value = Replace(r.Value, "オーナ", "オーナー")
r.Value = Replace(r.Value, "パートナ", "パートナー")
r.Value = Replace(r.Value, "マネージャー", "マネージャ")
r.Value = Replace(r.Value, "リーダー", "リーダ")
r.Value = Replace(r.Value, "メンバー", "メンバ")
r.Value = Replace(r.Value, "サマリー", "サマリ")
r.Value = Replace(r.Value, "サーバー", "サーバ")
r.Value = Replace(r.Value, "ルーター", "ルータ")
r.Value = Replace(r.Value, "ファイアーウォール", "ファイアーウォール")
r.Value = Replace(r.Value, "プロキシー", "プロキシ")
r.Value = Replace(r.Value, "インタフェース", "インターフェース")
r.Value = Replace(r.Value, "マネージメント", "マネジメント")
r.Value = Replace(r.Value, "ウィルス", "ウイルス")

r.Value = Replace(r.Value, "マスタ", "マスター")

Next r

'処理結果の一部修正

Dim myCell As Range
For Each myCell In Selection
'.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)
myCell.Value = Replace(myCell.Value, "(", "（")
myCell.Value = Replace(myCell.Value, ")", "）")
myCell.Value = Replace(myCell.Value, "携帯電話電話", "携帯電話")

Next myCell

MsgBox ("　処理が完了しました　")

end sub

以上です。

回答No.5

Nouble

何度も済みません、
…以降の部分を中心に、かなりはしょりますが、
こんな感じで

ヴァリアント型の変数を用意し
(借りに中間文字群、変換ビフォー、変換アフターとする）

'…　～文字列置換
Dim 中間文字群 As Variant, 変換ビフォー As Variant, 変換アフター As Variant, Dic As object, 鍵 As Variant,…
　　Set Dic = CreateObject("Scripting.Dictionary")
　　中間文字群 = Split("甲,乙,丙,呈,…　　",",")
　　変換ビフォー = Split("デジカメ,携帯,仮開通試験,入管,…　　,マスタ",",")
　　変換アフター = Split("デジタルカメラ,携帯電話,,入館,…　　,マスター",",")

'中間文字列の使用状況を確認する
　　For Each　シート型カウンタ用変数の名 In 対象範囲のブック
　　　　With　シート型カウンタ用変数の名
　　　　　　For Each　レンジ型カウンタ用変数の名 In .対象範囲のシート
　　　　　　　　For Long型カウンター用変数の名1 = LBound（中間文字群) To UBound(中間文字群)
　　　　　　　　　　Set レンジ型一時使用用変数の名 = レンジ型カウンタ用変数の名.Find(中間文字群(Long型カウンター用変数の名)…
　　　　　　　　　　If レンジ型一時使用用変数の名 Is Nothing _
　　　　　　　　　　Then
　　　　　　　　　　　　Dic.Add 中間文字群(Long型カウンター用変数の名), "_"
　　　　　　　　　　End If
　　　　　　　　Next Long型カウンター用変数の名1
　　　　　　Next レンジ型カウンタ用変数の名
　　　　End With
　　Next シート型カウンタ用変数の名
　　鍵 = Dic.Keys

'中間文字に置き換え
　　Long型カウンター用変数の名1 = 1 - 1　'Dicの最初の配列要素は1から始まる
　　For Each　ヴァリアント型カウンタ用変数の名1 In 変換ビフォー
　　　　For Each　ヴァリアント型カウンタ用変数の名2 In 変換アフター
　　　　　　If ヴァリアント型カウンタ用変数の名1 Like ヴァリアント型カウンタ用変数の名2 In 変換アフター _
　　　　　　Then
　　　　　　　　For Long型カウンター用変数の名2 = LBound（中間文字群) To UBound(中間文字群)
　　　　　　　　　　If ブーリアン型変数の名(Long型カウンター用変数の名1)　_
　　　　　　　　　　Then
　　　　　　　　　　　　Long型カウンター用変数の名1 = Long型カウンター用変数の名1 + 1
　　　　　　　　　　　　If Dic.Count >= Long型カウンター用変数の名1 _
　　　　　　　　　　　　Then
　　　　　　　　　　　　　　Dic.Item(鍵(Long型カウンター用変数の名1)) = ヴァリアント型カウンタ用変数の名1
　　　　　　　　　　　　　　With 対象範囲のブック.対象範囲のシート
　　　　　　　　　　　　　　　　.Cells.Replace What:= ヴァリアント型カウンタ用変数の名1 Replacement:= 中間文字群(Long型カウンター用変数の名1) LookAt:= xlPart
　　　　　　　　　　　　　　End With
　　　　　　　　　　　　Else
　　　　　　　　　　　　　　MsgBox("中間的置換対象文字群が足りません")
　　　　　　　　　　　　　　Exit Sub
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　　　Next Long型カウンター用変数の名2
　　　　　　End If
　　　　Next ヴァリアント型カウンタ用変数の名2
　　Next ヴァリアント型カウンタ用変数の名1

'置換開始
　　For Long型カウンター用変数の名1 = LBound（変換ビフォー) To UBound（変換ビフォー)
　　　　With 対象範囲のブック.対象範囲のシート
　　　　　　.Cells.Replace What:= 変換ビフォー(Long型カウンター用変数の名1) Replacement:= 変換アフター(Long型カウンター用変数の名1) LookAt:= xlPart
　　　　End With
　　Next Long型カウンター用変数の名1

'中間文字列の書き戻し
　　For Long型カウンター用変数の名1 = 1 To Dic.Count
　　　　With 対象範囲のブック.対象範囲のシート
　　　　　　.Cells.Replace What:= 鍵(Long型カウンター用変数の名1) Replacement:= Dic.Item(鍵(Long型カウンター用変数の名1)) LookAt:= xlPart
　　　　End With
　　Next Long型カウンター用変数の名1
End Sub

即興で書いたので、バグがうじょうじょ居るかも知れません。
なので、
かなり手直しがこのままではいるかも知れませんが
雰囲気はこんな感じでしょうか？

如何でしょうか？
お役に立てていたならば幸いです。

………
……
…
…
…

あれ？　ひょっとしてVBSなのですか？
Scripting.Dictionary使えなかったらどうしよう…
ヴァリアント型配列を動的配列として運用すれば同じ事が出来るけれど…
きっと効率落ちるよね？

回答No.4

cj_mover

＃３、ｃｊです。

全体的に、ご提示のコードを元に効率化を図りながら書きました。
速くする工夫なら色々ありそうですが、
遅さの解消という意味では優先度の高いものは大体
反映したものが書けていると思います。
その分、取っ付き難いかも知れませんが焦らずに取り組んでみてください。
疑問があれば補足欄にでも書いてみてください。

　※ 参照設定 の件、半角カナ文字パターン の件、くれぐれも間違えないでください。

' ' 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
' ' ◆参照設定：Microsoft VBScript Regular Expressions 5.5◆
Option Explicit

' ' Private Const PTRn2w = "[ァ-゜\(\)]+" ' = "[\uFF66-\uFF9F\(\)]+" ' ←サイトの都合で文字化けします。
' ' ■重要■別途piyoを実行後、イミディエイトウィンドウからこの行にコピペ■
　　Private Const PTRw2n = "[０-９＠-～]+" ' = "[\uFF10-\uFF5E]+"
　　Private Const PTRcell = "(携帯)([^電$]|$)"
　　Private Const RPCPTRcell = "$1電話$2"

' ' 長音付加検索単語テーブルregexp
　　Private Const TBFINDbar = "センタ,オーナ,パートナ,マスタ"
　　Private Const PTRbarL = "("
　　Private Const PTRbarR = ")([^ー]|$)"
' ' 長音付加置換パターン
　　Private Const RPCPTRbar = "$1ー$2"

' ' 検索単語テーブルreplace
　　Private Const TBFIND = "デジカメ,仮開通試験,入管,マネージャー,リーダー,メンバー,サマリー,サーバー,ルーター,ファイアーウォール,プロキシー,インタフェース,マネージメント,ウィルス"
' ' 置換単語テーブルreplace
　　Private Const TBRPC = "デジタルカメラ,,入館,マネージャ,リーダ,メンバ,サマリ,サーバ,ルータ,ファイアウォール,プロキシ,インターフェース,マネジメント,ウイルス"

'　　Private oRegExp As Object '◆１／２択◆参照設定しなかった場合
　　Private oRegExp As VBScript_RegExp_55.RegExp '◆２／２択◆参照設定した場合
'　　Private oMatches As Object '◆１／２択◆参照設定しなかった場合
　　Private oMatches As VBScript_RegExp_55.MatchCollection '◆２／２択◆参照設定した場合
'　　Private oM As Object '◆１／２択◆参照設定しなかった場合
　　Private oM As VBScript_RegExp_55.Match '◆２／２択◆参照設定した場合

　　Private arrFindBar() As String
　　Private arrFind() As String
　　Private arrRpc() As String

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Sub Re8102506jMain() ' 実行プロシージャ
　　Dim rTgt As Range
　　Dim r As Range
　　Dim sBuf As String
'Dim t As Single: t = Timer

　　arrFindBar() = Split(TBFINDbar, ",")
　　arrFind() = Split(TBFIND, ",")
　　arrRpc() = Split(TBRPC, ",")
　　If UBound(arrFind()) <> UBound(arrRpc()) Then MsgBox "Constミス": Exit Sub

　　If TypeName(Selection) <> "Range" Then MsgBox "セル範囲を選択": Exit Sub

　　Set rTgt = Selection.SpecialCells(Type:=xlCellTypeConstants, Value:=xlTextValues)
　　If rTgt Is Nothing Then MsgBox "文字列定数セル無し": Exit Sub

'　　Set oRegExp = CreateObject("VBScript.RegExp") '◆１／２択◆参照設定しなかった場合
　　Set oRegExp = New VBScript_RegExp_55.RegExp '◆２／２択◆参照設定した場合
　　oRegExp.Global = True

　　With Application
　　　　.ScreenUpdating = False
　　　　.EnableEvents = False
　　　　.Calculation = xlCalculationManual
　　End With

　　For Each r In rTgt
　　　　sBuf = r.Value
　　　　If sBuf <> "" Then
　　　　　　Call Re8102506jSub(sBuf)
　　　　　　r.Value = sBuf
　　　　End If
　　Next

'Debug.Print Timer - t
　　With Application
　　　　.Calculation = xlCalculationAutomatic
　　　　.EnableEvents = True
　　　　.ScreenUpdating = True
　　End With
　　Set rTgt = Nothing:　　Set oRegExp = Nothing:　　Set oMatches = Nothing
　　Erase arrFindBar(), arrFind(), arrRpc()
'Debug.Print Timer - t
　　MsgBox ("　処理が完了しました　")
End Sub

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Sub Re8102506jSub(sBuf As String)
　　Dim v
　　Dim i As Long

　　With oRegExp

' ' 「半角小文字"ァ" から 半角半濁点」「半角括弧"(",")"」すべて 全角 に置換
　　　　.Pattern = PTRn2w ' "[ァ-゜\(\)]+"
　　　　Set oMatches = .Execute(sBuf)
　　　　For Each oM In oMatches
　　　　　　sBuf = Replace$(Expression:=sBuf, Find:=oM.Value, _
　　　　　　　　　　　　Replace:=StrConv(oM.Value, vbWide), Count:=1)
　　　　Next oM

' ' ０１２３４５６７８９
' ' ＠ＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰＱＲＳＴＵＶＷＸＹＺ
' ' ［＼］＾＿｀ａｂｃｄｅｆｇｈｉｊｋｌｍｎｏｐｑｒｓｔｕｖｗｘｙｚ｛｜｝～
' ' すべて 全角 から 半角 に置換
　　　　.Pattern = PTRw2n ' "[０-９＠-～]+"
　　　　Set oMatches = .Execute(sBuf)
　　　　For Each oM In oMatches
　　　　　　sBuf = Replace$(Expression:=sBuf, Find:=oM.Value, _
　　　　　　　　　　　　Replace:=StrConv(oM.Value, vbNarrow), Count:=1)
　　　　Next oM

' ' 長音付加　　長音付加検索単語テーブルregexp
　　　　For Each v In arrFindBar()
　　　　　　.Pattern = PTRbarL & v & PTRbarR ' "(検索語)([^ー]|$)"
　　　　　　If .Test(v) Then sBuf = .Replace(sBuf, RPCPTRbar) ' "$1ー$2"
　　　　Next

　　　　.Pattern = PTRcell ' "(携帯)([^電$])"
' ' 携帯 を 携帯電話 に置換
　　　　If .Test(sBuf) Then sBuf = .Replace(sBuf, RPCPTRcell) ' "$1電話$2"

　　End With

' ' 検索単語テーブルに 対応する 定義した置換単語テーブル へそれぞれ置換
　　For Each v In arrFind()
　　　　If InStr(sBuf, v) Then sBuf = Replace$(sBuf, v, arrRpc(i))
　　　　i = i + 1
　　Next

End Sub

' ' 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

回答No.3

cj_mover

こんにちは。
文字数制限に掛かるので、２連投します。

検証用のダミーサンプル（1000*10）（意地悪サンプル）作るのに手間取ってしまいました。
でも、コードをみると質問者さんも頑張っているみたいなので、、、と。
（# セクション毎にどなたが書いたものが原型か想像つきますね）

さておき、

Replace()関数が遅いというのは、
ヒットしなくても構わず置換しているからです。
通常、Replace()関数はInStr()関数と組合わせて使い
ヒットした場合だけ置換することで無駄な処理を省きます。
また、Replace$()関数を使った方が少し速くなります。

次に基本的な部分。
Selectionで取得されるRangeオブジェクトは、
今回の処理のどの部分でも、変わらない、ということに注目して考えてみてください。
オブジェクトへの取得は１回で済ませるようにしましょう。
Selection と 何回も追いかけるなら。
変数にセットするか、With ステートメントで括るかして、
一か所で済ませるようにしましょう。
今回の課題では、Selectionの中には数式が設定してあるセルも含まれていて、
数式にも戻り値にも置換は掛けない、ということを想定しているようですから、
　　Set rTgt = Selection.SpecialCells(Type:=xlCellTypeConstants, Value:=xlTextValues)
という風に最初にセットしておいて、後は変数に対して処理していきます。

ご提示のコードでは、同じセル範囲のループを何度も繰り返していますが、
これも、なるべく一カ所に纏めるようにしましょう。
セル範囲を呼び出す回数が多ければ多い程、
処理は遅くなります。
すぐに出来ないのは仕方ないけれど、意識する心掛けだけでも、
今後の上達の援けになると思います。

半角から全角へ置換するキャラセットに、半角括弧を加えたパターンに換えました。
半角カナ文字をこのサイトに表示することは出来ませんので、
' ' ■重要■別途piyoを実行後、イミディエイトウィンドウからこの行にコピペ■
の指示通り、以下の３行プロシージャを実行し、
イミティエイトウィンドウに出力された記述を、
指定の宣言部に貼り付けて使ってください。
' ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
　Private Sub piyo()
　Debug.Print "Private Const PTRn2w = ""[" & Chr(167) & "-" & Chr(223) & "\(\)]+"""
　End Sub
' ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

全角から半角へ置換するパターン２種類を、ひとつに纏めました。

一旦「携帯→携帯電話」と置換して「携帯電話電話→携帯電話」と置換し直すのをやめて
「携帯」の次に「電」の文字がない「携帯」だけを「携帯電話」に置換する処理
を、正規表現で纏めました。
同様に長音付加はついても正規表現で置換する必要がある為、
長音付加検索単語テーブルを定数にしました。
パターンは、"(検索語)([^ー]|$)" となります。

文字列を置換する部分をサブルーチンにして参照渡しでやりとりさせています。

Applicationの「描画更新」「イベント」「再計算」を
一時的にキャンセルして遅くなる原因を除いてます。

　検索単語テーブル　*2種、　置換単語テーブル
カンマ区切りで一連の文字列に纏めていますが、扱いに注意してください。
相対的な位置関係が狂うと無茶苦茶な置換になってしまいます。
本来は、シート上にテーブルを作表しておいた方がやり易いです。
余裕があったら改善してみてください。

'事前バインディング'　'アーリーバインディング'
一般論として、外部オブジェクトは事前に参照設定しておいた方が、
処理が速くなりますし、コーディンヅのヒントが得られることもありますから
正規表現覚えるのでしたら、まず、参照設定から始めましょう。
VBEのメニュー［ツール］［参照設定］リストのちょうど中段位にスクロールして
□　Microsoft VBScript Regular Expressions 5.5
を探し、チェックを付けて［ＯＫ］で設定完了です。

Replace()関数を使ってMatch.Valueを置換する場合、
　　　　　　sBuf = Replace$(Expression:=sBuf, Find:=oM.Value, _
　　　　　　　　　　　　Replace:=StrConv(oM.Value, vbWide), Count:=1)
このように、Count:=1 を指定する必要があります。

次の投稿で、私が書いたものを提示します。
予想より大掛りでしたので、検証も十分とはいえません。
こちらで何か漏れがあるといけないので、検証は慎重になさってください。
ご指摘あれば、または、こちらで気が付いたことがあれば、
追記するかも知れません。

///

（つづく．．．）

回答No.2

Nouble

横から関係ないことを云い済みません。
置換のテクニックで一言良いでしょうか？

r.Value = Replace(r.Value, "マスタ", "マスター")
とありますが、
此は恐らく
"マスタ", "マスター"が混在していて、"マスター"に統一したい
と、云うご意志だと思いますが、

このままでは"マスター"の内の
頭から３文字"マスタ"に反応して
此を"マスター"に変換し、
結果"マスターー"にしてしまうのではないでしょうか？
本末転倒ですよね？

こういう場合のテクニックとして
予め使われそうもない語彙を幾つか用意しておいて
(例えば甲乙丙丁など)
全文中で使われていないか確認後
(仮に丙が使われていなかったとします)
"マスター"を丙に書き換え
"マスタ"を"マスター"に書き換え
丙を"マスター"に書き戻せば回避できます。

"携帯", "携帯電話"
も同じ事ですよね？
"携帯電話電話"なんて
恥ずかしい結果が出てしまいますよ?

まあ"ーー"や"電話電話"なんてものがあり得ない
と、言切れるならば
"ーー"や"電話電話"を探し、
なくなるまで"ー"や"電話"に変換すれば良い
ということですが、
実際にこうされているようですが、
此は危険だと思いますよ？

横から済みません
お役に立てていたならば幸いです。

回答No.1

noname#203218

Replace関数を使用されていますが、Replaceメソッドの方が早く処理するようです。
理由は関数はセル毎に処理するのに対し、メソッドは指定範囲に処理するので早くなるのだそうです。
http://www.moug.net/tech/exvba/0140046.html

Selection.SpecialCells(xlCellTypeConstants, xlTextValues).Select

Selection.Cells.Replace "デジカメ", "デジタルカメラ", xlPart
Selection.Cells.Replace "携帯", "携帯電話", xlPart
Selection.Cells.Replace "仮開通試験", "", xlPart
Selection.Cells.Replace "入管", "入館", xlPart
Selection.Cells.Replace "オーナ", "オーナー", xlPart
Selection.Cells.Replace "パートナ", "パートナー", xlPart
Selection.Cells.Replace "リーダー", "リーダ", xlPart
Selection.Cells.Replace "メンバー", "メンバ", xlPart
Selection.Cells.Replace "サマリー", "サマリ", xlPart
Selection.Cells.Replace "サーバー", "サーバ", xlPart
Selection.Cells.Replace "ルーター", "ルータ", xlPart
Selection.Cells.Replace "ファイアーウォール", "ファイアーウォール", xlPart
Selection.Cells.Replace "プロキシー", "プロキシ", xlPart
Selection.Cells.Replace "インタフェース", "インターフェース", xlPart
Selection.Cells.Replace "マネージメント", "マネジメント", xlPart
Selection.Cells.Replace "ウィルス", "ウイルス", xlPart
Selection.Cells.Replace "マスタ", "マスター", xlPart

指定文字列１９を２行毎の連結セル(チェック)４列文の置換作業の処理時間を計測した所、関数で2.47秒に対し、メソッドでは0.08秒で処理しており、処理速度は30倍メソッドが早い結果となっています。

構文的には、検索文字、置換文字を配列に格納してDO～LOOP処理する方がすっきりするように思えます。
一文として下記のうような、シート２に検索文字、置換文字を記入しておき、配列に格納、シート１を置換する。
Sub test()
Dim Sw(19) As String '検索文字
Dim Cw(19) As String '置換文字
Dim i As Integer
Dim sn As Worksheet

Set sn = Worksheets("sheet2")

For i = 1 To 19
Sw(i) = sn.Cells(i, 1).Value
Cw(i) = sn.Cells(i, 2).Value
Next

Worksheets("sheet1").Activate
Selection.SpecialCells(xlCellTypeConstants, xlTextValues).Select

i = 1

Do

Selection.Cells.Replace Sw(i), Cw(i), xlPart

i = i + 1

Loop Until i = 20

End Sub

他にも速度を早くする方法はあるかと思いますが、ご参考まで。