【Excel VBA】フォルダ（サブデータ含む）リンク取得の高速化

初心者です。

ExcelのVBAで特定のフォルダをサブデータまでリンクを付けた状態で抽出するコードを書いたのですが
処理が20分くらいかかっているので処理速度を上げたいです。
（反映すると大体5000行程度）

ネットで調べて
・自動計算をしない
・描画をしない
・イベントの抑止

までやってみたた結果での20分です。
全く知識がない状態で全部ネットで拾ってきたコードなので何が遅くなっているのかもわからない状態なのでお知恵を拝借したく
以下コードの内容です

Public findPath As String
Sub フォルダ取得()

    With Application
        .Calculation = xlCalculationManual  '計算を手動に
        .EnableEvents = False  'イベントを抑止
        .ScreenUpdating = False  '画面描画を停止
    End With

Dim fso As Object
Dim cf As Variant
Dim oRow, oCol As Integer

findPath = "フォルダのリンク先  '←取得したいフォルダパスを指定する

oRow = 3 '←出力開始の行を指定
oCol = 2 '←出力開始の列を指定

'指定フォルダを出力
Cells(oRow, oCol) = findPath
ActiveSheet.Hyperlinks.Add anchor:=Cells(oRow, oCol), Address:=findPath
    
Set fso = CreateObject("Scripting.FileSystemObject")
Set cf = fso.GetFolder(findPath)

'フォルダ全探査
Call GetSubFolder(cf, oRow + 1, oCol)

End Sub

'===============================================================================
'   フォルダ単位で全探査
'===============================================================================
Sub GetSubFolder(cf, oRow, oCol)
'ファイル出力処理
For Each f In cf.Files
    fLevel = UBound(Split(Replace(f.Path, findPath, ""), "\"))
    Cells(oRow, oCol + fLevel) = f.Name
    Call lineDraw(oRow, oCol, fLevel) '罫線を引く
    ActiveSheet.Hyperlinks.Add anchor:=Cells(oRow, fLevel + oCol), Address:=f.Path 'ハイパーリンク化
    oRow = oRow + 1
Next

'サブフォルダ処理
For Each f In cf.SubFolders
    fLevel = UBound(Split(Replace(f.Path, findPath, ""), "\"))
    Cells(oRow, oCol + fLevel) = f.Name
    Call lineDraw(oRow, oCol, fLevel) '罫線を引く
    ActiveSheet.Hyperlinks.Add anchor:=Cells(oRow, fLevel + oCol), Address:=f.Path 'ハイパーリンク化
    oRow = oRow + 1
    
    Call GetSubFolder(f, oRow, oCol) '再帰呼出
Next

End Sub

Sub lineDraw(oRow, oCol, fLevel) '罫線を引く

For i = oCol + fLevel - 1 To oCol Step -1
    If i = oCol + fLevel - 1 Then
        Cells(oRow, i) = ChrW(&H23BF)
    Else
        Cells(oRow, i) = "│"
    End If
    Cells(oRow, i).HorizontalAlignment = xlCenter
Next

        
    With Application
        .Calculation = xlCalculationAutomatic  '計算を自動に'
        .EnableEvents = True  'イベントを再開'
        .ScreenUpdating = True  '画面描画を開始'
    End With
    
End Sub

よろしくお願いいたします。

退会済みユーザー

2022/02/20 06:14

時間のかかる要素としては、罫線の書き込みとハイパーリンクの設定があります。それぞれを省略して時間の計測をしてみましょう。話はそれからです。

lay.

2022/02/20 07:06

なるほど！ありがとうございます。ハイパーリンクはマストなので、罫線を表示しない方向で一旦実行してみようと思います！

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

回答1件

ベストアンサー

5000行程度で20分とは時間がかかりすぎですね。

当方で、適当なフォルダー(ファイル数4000, フォルダー数50)に対して提示のコードを実行したところ1分もかかりませんでした。

Hyperlinks.Addは重そうなので、HYPELINK関数でリンクさせたらどうでしょう。

当方のテストでは、10分の１ぐらいの時間で完了しました。

vba
1Sub GetSubFolder(cf, oRow, oCol)
2    'ファイル出力処理
3    For Each f In cf.Files
4        fLevel = UBound(Split(Replace(f.Path, findPath, ""), "\"))
5'        Cells(oRow, oCol + fLevel) = f.Name
6        Cells(oRow, oCol + fLevel).Formula = "=HYPERLINK(""" & f.Path & """,""" & f.Name & """)"
7        Call lineDraw(oRow, oCol, fLevel)        '罫線を引く
8'        ActiveSheet.Hyperlinks.Add anchor:=Cells(oRow, fLevel + oCol), Address:=f.Path 'ハイパーリンク化
9        oRow = oRow + 1
10    Next
11
12    'サブフォルダ処理
13    For Each f In cf.SubFolders
14        fLevel = UBound(Split(Replace(f.Path, findPath, ""), "\"))
15'        Cells(oRow, oCol + fLevel) = f.Name
16        Cells(oRow, oCol + fLevel).Formula = "=HYPERLINK(""" & f.Path & """,""" & f.Name & """)"
17        Call lineDraw(oRow, oCol, fLevel)        '罫線を引く
18'        ActiveSheet.Hyperlinks.Add anchor:=Cells(oRow, fLevel + oCol), Address:=f.Path 'ハイパーリンク化
19        oRow = oRow + 1
20    
21        Call GetSubFolder(f, oRow, oCol)         '再帰呼出
22    Next
23End Sub

あと、下記の画面描画抑制などを解除する処理がlineDraw内にありますが、これだとすぐに解除されてしまいます。メイン処理(フォルダ取得)内の最後に移動させてください。

vba
1    With Application
2        .Calculation = xlCalculationAutomatic  '計算を自動に'
3        .EnableEvents = True  'イベントを再開'
4        .ScreenUpdating = True  '画面描画を開始'
5    End With