統合セルのマクロ処理について
お世話になっております。
現在マクロにて選択した範囲のセルにおいて
半角・全角・単語の書式を統一する処理をおこなっていますが、
統合されたセルが入ってくるととたんに処理に時間がかかってしまいます。
（対象となるシートの書式はさまざまです。）
なんとか解消したいのですが、ご教示お願いできませんでしょうか？
以下マクロになります。
すみませんが、なにとぞよろしくお願い致します。
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
以上です。
お礼
回答ありがとうございます。 仰る通り、wwwでないものについて考慮できていませんでしたね…。 ちょっと正規表現を見直してみます。