ExcelのVBAのループで時間短縮する方法を教えてださい。

質問

ExcelのVBAのループで時間短縮する方法を教えてださい。

F2～H列最終行にある、株式会社や有限会社を(株)や(有)に置き換えるために
下記のようなループを使っています。
でも、数万行とかある場合、結構時間がかかります。
もっと短時間で動かせるコードの書き方がありましたら教えてください。
よろしくお願いいたします。

For Each MyRange In Range("F2:H" & 最終行)
MyRange.Value = Replace(MyRange.Value, "株式会社", "(株)")
MyRange.Value = Replace(MyRange.Value, "　株式会社", "(株)")
MyRange.Value = Replace(MyRange.Value, "株式会社　", "(株)")
MyRange.Value = Replace(MyRange.Value, "有限会社", "(有)")
MyRange.Value = Replace(MyRange.Value, "　有限会社", "(有)")
MyRange.Value = Replace(MyRange.Value, "有限会社　", "(有)")
MyRange.Value = Replace(MyRange.Value, "(有)　", "(有)")
MyRange.Value = Replace(MyRange.Value, "　(有)", "(有)")
MyRange.Value = Replace(MyRange.Value, "(株)　", "(株)")
MyRange.Value = Replace(MyRange.Value, "　(株)", "(株)")
Next

回答No.5

cj_mover · ベストアンサー

お邪魔します。
置換の手順がちょっとおかしいような気がしたもので、、、。

配列変数を使うのが速いでしょうけど、こんな感じでどうでしょう。
App系の更新停止をする場合は、必ず解除もしてください。
中間に他の記述を追記するなら、エラー処理を検討してください。
　Replace()関数についてはVBAのヘルプ等で確認してください。

Sub Re6140122()
　Dim 最終行 As Long
　Dim i As Long, j As Long
　Dim arr As Variant
'　　With Application　' App系の処理は状況次第で。必ず要るという訳でもなく、、、
'　　　　.ScreenUpdating = False　' データが大量の場合のみメリットあり（←配列出力の記述では）
'　　　　.Calculation = xlCalculationManual　' シート上での関数使用状況
'　　　　.EnableEvents = False　' SelectionChange イベント | Change イベント 等を使うなら
'　　End With
　最終行 = Cells(Rows.Count, "H").End(xlUp).Row
　With Range("F2:H" & CStr(最終行))
　　' ' セル範囲の値をVariant型の配列変数に格納
　　arr = .Value
　　For i = 1 To 最終行 - 1
　　　For j = 1 To 3
　　　　' ' (株)｜(有)　に統一
　　　　arr(i, j) = Replace(arr(i, j), "株式会社", "(株)")
　　　　arr(i, j) = Replace(arr(i, j), "有限会社", "(有)")
　　　　' ' 括弧（全角｜半角）を半角に統一 # 必要ありませんかね？
　　　　arr(i, j) = Replace(arr(i, j), "(株)", "(株)", , , 1)
　　　　arr(i, j) = Replace(arr(i, j), "(有)", "(有)", , , 1)
　　　　' ' (株)｜(有)の前後のスペース（全角｜半角）を削除
　　　　arr(i, j) = Replace(arr(i, j), "　(株)", "(株)", , , 1)
　　　　arr(i, j) = Replace(arr(i, j), "(株)　", "(株)", , , 1)
　　　　arr(i, j) = Replace(arr(i, j), "　(有)", "(有)", , , 1)
　　　　arr(i, j) = Replace(arr(i, j), "(有)　", "(有)", , , 1)
　　　Next j
　　Next i
　　.Value = arr
　End With
'　　With Application
'　　　　.ScreenUpdating = True
'　　　　.Calculation = xlCalculationAutomatic
'　　　　.EnableEvents = True
'　　End With
End Sub

お礼

ありがとうございます。
置換の手順がおかしかったです！
無駄な作業をしていました。
本当に助かりました。

回答No.9

tom04

No.8です！
たびたびごめんなさい。

微々たるものでしょうけど、前回のコードは各セルの最終文字まで調べてしまいます。
「株式会社」「有限会社」ともに4文字ですので、各セルの最終文字から4文字前までマクロを実行すれば良いと思います。
と言う訳で、少しコードを訂正させていただきます。

Sub test()
Dim i, j, k As Long
Dim str As String
For i = 1 To ActiveSheet.UsedRange.Rows.Count
For j = 1 To ActiveSheet.UsedRange.Columns.Count
For k = 1 To Len(Cells(i, j)) - 3
str = Mid(Cells(i, j), k, 4)
If str = "株式会社" Then
Cells(i, j) = Replace(Cells(i, j), str, "（株）")
ElseIf str = "有限会社" Then
Cells(i, j) = Replace(Cells(i, j), str, "（有）")
End If
Next k
Next j
Next i
End Sub

実際どの程度短縮されるかは判りません。
何度も失礼しました。m(__)m

お礼

ありがとうございます。私の書いたコードだと同じ構文を繰り返していて、見栄えが悪いというかVBAというよりマクロっぽいと気になっていたので、上記のようなコードの書き方をすればすっきりしますね。助かりました！

回答No.8

tom04

こんばんは！
すでに回答は出ているようなので、参考程度で目を通してみてください。

一例です。
考え方は各セルを1文字ずつ（4文字を一まとめにして）、舐めるように順番に見てゆきます
もし「株式会社」であれば（株）に、「有限会社」であれば（有）に置き換えるようにしてみました。

Sub test()
Dim i, j, k As Long
Dim str, buf As String
For i = 1 To ActiveSheet.UsedRange.Rows.Count
For j = 1 To ActiveSheet.UsedRange.Columns.Count
For k = 1 To Len(Cells(i, j))
str = Mid(Cells(i, j), k, 1)
buf = Mid(Cells(i, j), k, 4)
If buf = "株式会社" Then
Cells(i, j) = Replace(Cells(i, j), buf, "（株）")
ElseIf buf = "有限会社" Then
Cells(i, j) = Replace(Cells(i, j), buf, "（有）")
End If
Next k
Next j
Next i
End Sub

上記のマクロを試すときは別Sheetにコピー＆ペーストして行ってみてください。

以上、参考になればよいのですが・・・m(__)m

回答No.7

layy

「同じエリアに対してReplaceを　　１０回も　　やってやること」
「対象文字があってもなくてもReplaceを行っていること」
「一度『株式会社』が『（株）』に置換できたら『株式会社　』の置換は不要」

こういうことが、遅くしている要因と思います。
ロジックを見なおしてください。

さらには
ＶＢＡが使えたらの話で、
「エクセル（セル操作）でやっていること」も遅く、テキストデータの入出力のが早いかもしれない。
情報をＣＳＶファイルで保存しておいて、ＣＳＶファイル上でやってみる。
文字列置換のロジックはＶＢＡで提供ありますし、
ファイル１レコードを読み込み、検知と置換、書き込み、の繰り返しです。

お礼

ありがとうございます。
置換の手順がおかしかったです！
無駄な作業をしていました。
本当に助かりました。

回答No.6

DOUGLAS_

#5 さんがお書きの
＞置換の手順がちょっとおかしいような気がした
ということと同じことかも知れませんが。。。

"株式会社" → "(株)"
の置換が済んだ時点で、
"　株式会社" → "　(株)"
"株式会社　" → "(株)　"
となります。

　従って、ステップインデバッグ していただくと一目瞭然ですが、
"　株式会社" → "(株)"
"株式会社　" → "(株)"
"　有限会社" → "(有)"
"有限会社　" → "(有)"
の４行は無意味です（余計な時間を費やします）。

お礼

ありがとうございます。
置換の手順がおかしかったです！
無駄な作業をしていました。
本当に助かりました。

回答No.4

myRange

Replaceメソッドはどうでしょうか。

'--------------------------------------
Sub test()
　　Dim myRange As Range
　　Set myRange = Range("F2", Cells(Rows.Count, "H").End(xlUp))

　　With myRange
　　　　　.Replace "株式会社", "(株)", xlPart
　　　　　.Replace "　株式会社", "(株)", xlPart
　　　　　.Replace "株式会社　", "(株)", xlPart
　　　　　.Replace "有限会社", "(有)", xlPart
　　　　　.Replace "　有限会社", "(有)", xlPart
　　　　　.Replace "有限会社　", "(有)", xlPart
　　　　　.Replace "(有)　", "(有)", xlPart
　　　　　.Replace "　(有)", "(有)", xlPart
　　　　　.Replace "(株)　", "(株)", xlPart
　　　　　.Replace "　(株)", "(株)", xlPart
　　End With
End Sub
'-------------------------------------

言わずもがなですが、テストはコピーしてから。
以上です。

回答No.3

mitarashi

#1に追加して、高速化3点セットです。
Sub test()
Dim i As Long, j As Long
Dim buf As Variant

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
buf = Range("F2:H" & 最終行)
For i = 1 To 最終行 - 1
For j = 1 To 3
buf(i, j) = Replace(buf(i, j), "株式会社", "(株)")
'以下　略
Next j
Next i
Range("F2:H" & 最終行) = buf
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

回答No.2

kmetu

単純に

For Each MyRange In Range("F2:H" & 最終行)

If InStr(MyRange, "株式会社") Then
MyRange.Value = Replace(MyRange.Value, "株式会社", "(株)")
MyRange.Value = Replace(MyRange.Value, "　株式会社", "(株)")
MyRange.Value = Replace(MyRange.Value, "株式会社　", "(株)")

ElseIf InStr(MyRange, "有限会社") Then
MyRange.Value = Replace(MyRange.Value, "有限会社", "(有)")
MyRange.Value = Replace(MyRange.Value, "　有限会社", "(有)")
MyRange.Value = Replace(MyRange.Value, "有限会社　", "(有)")

ElseIf InStr(MyRange, "(有)") Then
MyRange.Value = Replace(MyRange.Value, "(有)　", "(有)")
MyRange.Value = Replace(MyRange.Value, "　(有)", "(有)")

ElseIf InStr(MyRange, "(株)") Then
MyRange.Value = Replace(MyRange.Value, "(株)　", "(株)")
MyRange.Value = Replace(MyRange.Value, "　(株)", "(株)")

End If

Next

のようにしても多少早くなりますよ

回答No.1

okormazd

For Each
の前に，
Application.ScreenUpdating = False
Next
の後に，
Application.ScreenUpdating = true
を入れて，実行してみてください。

補足

ありがとうございます。
申し訳ございません。
Application.ScreenUpdating = False
は入れてあります。
補足にいれます。