文書抽出のVBA、動作を改善したい

前提・実現したいこと

特定の文字をImputBoxに入力し、その文字に該当する文を、文章一覧から抽出するVBAを書きました。
文書一覧の行を増やしていったら、現在１５０行くらいになっており、動作に１０秒ほどかかっている状態です。
これから、文書一覧を増やしていきたいと考えているのですが、このままだとどんどん動作が遅くなりそうです。
VBAを始めたばかりなで、非効率な関数などを使用しているためだと思いますが、完成させるのに精一杯でした。改善策をご教授いただければ幸いです。よろしくお願いいたします。

該当のソースコード

VBA
1Sub 実行()
2
3    Dim buf As String
4    Dim Last_Row As Long
5    Dim MaxRow As Long   '最終セルの行番号
6    Dim MaxColumn As Integer   '最終セルの列番号
7    Dim ws As Worksheet
8    Dim i As Long
9    Dim j As Long
10    Dim msg As String, dm As String
11      
12      
13    '最終行を取得
14    Worksheets("文書一覧").Activate
15    Set ws = ActiveSheet
16    
17    MaxRow = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
18    MaxColumn = ws.UsedRange.Columns(ws.UsedRange.Columns.Count).Column
19        
20    'シート２のクリア
21    Worksheets("Sheet2").Cells.Clear
22    
23    '検索文字の呼び込み
24    msg = "検索したい文字を入力してください"
25    dm = InputBox(msg)
26    
27    'シート２に転記
28    For j = 1 To MaxColumn
29    
30        For i = 2 To MaxRow
31        
32        Worksheets("文書一覧").Activate
33        Cells(i, j).Activate
34        buf = ActiveCell.Value
35        If InStr(buf, dm) > 0 Then
36            Sheet2.Select
37            ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
38            ActiveCell.Value = buf
39            buf = ""
40        End If
41        Next i
42    Next j
43
44Sheet2.Select
45   
46End Sub
47

行動規範の内容に同意します

回答1件

ベストアンサー

「VBA 高速化」で検索すれば、いろいろ対策が見つかりますので、一通り目を通しておくいいでしょう。

処理の前に、画面描画を停止、処理後に戻す。

もし、シート上に多数の計算式があるなら自動計算を停止しておく。

ActivateやSelectはしない。しなくても対象のオブジェクトを変数にいれておけばそれに対して処理できる。

上記である程度は改善するでしょう。
（具体的なコードは検索すればすぐ見つかります。）

最終手段をは検索範囲を配列にいれて、配列を対象にループさせます。
これで劇的に改善します。
これも「VBA 高速化配列」をキーワードに検索すればサンプルコードはいろいろ見つかります。

上記を踏まえて、
自分が書くなら下記のような感じになります。

vba
1Sub 実行()
2    Application.ScreenUpdating = False
3    Application.Calculation = xlCalculationManual
4
5    Dim aryTar '検索対象を格納する配列
6    aryTar = Worksheets("文書一覧").UsedRange.Value
7
8    '検索文字の取得
9    Dim dm As String
10    dm = InputBox("検索したい文字を入力してください")
11
12    Dim aryRes() '結果格納配列
13    Dim cnt As Long '検索結果数格納用
14    
15    Dim buf
16    For Each buf In aryTar
17        If InStr(buf, dm) > 0 Then
18            ReDim Preserve aryRes(cnt)
19            aryRes(cnt) = buf
20            cnt = cnt + 1
21        End If
22    Next
23  
24    With Worksheets("Sheet2")
25        .Cells.Clear
26        .Cells(1, 1).Resize(cnt).Value = _
27               WorksheetFunction.Transpose(aryRes)
28    End With
29
30    Application.Calculation = xlCalculationAutomatic
31    Application.ScreenUpdating = True
32End Sub