【VBA_再帰】複数フォルダ内を検索拡張子を決めて画像を取り出す

再帰呼び出しを使ってフォルダ内から画像を抽出

EnjoyExcel

階層が異なるフォルダ群を確認しつつ周回するのは手間がかかるしコードも長くなります。

再帰呼び出し（処理）を使うと効率良く立ち回ることができますよ。

関連記事

再帰呼び出しが分かるようになる【ExcelVBA】再帰呼び出し（再帰処理）は3分の動画で理解できる

【ExcelVBA】再帰呼び出し（再帰処理）は3分の動画で理解できる

再帰呼び出し（再帰処理）について画像と非常に分かり易い動画を用いて解説していきます。今回の記事では再帰呼び出し自体の解説をします。再帰は非常に難しいのでコードを見ただけでは理解できません。そこでコードの流れが分かる画像と動画を用意しました。

www.slt-pgming-21.net

2024.01.23

再帰を勉強している方ならおそらくクラスも理解できます。興味がある方は以下記事をご覧ください。

クラスモジュールを解説VBA｜クラスとは何か｜本当に難しいのかを3つのポイントから検証

アウトプット

早速アウトプットを紹介しつつ解説していきます。

環境

3A-1に.jpgが1つ、1B-1に.jpegが3つ、2C-1に.pngが1つ、2C-2に.jpgが1つです。

ワークシート

パスでフォルダを指定後リストで拡張子を決めれば配下の画像を全て持ってくるという仕様です。

コード

ワークシートの実行ボタンに連動しているのはこのプロシージャになる様に準備をしてください。

Sub main()

'********************************************
Dim cnt As Long 'セルの行数
Dim r As Long '行の取得
Dim path As String 'パスを格納する変数
path = Range("H3").Value 'パスの初期値
cnt = 8 'セルの行数の初期値
'********************************************

Application.ScreenUpdating = False

'画像が居る行の最終行を取得する為のプロシージャへ飛ぶ
Call rowsCount(r)

'ここで8行目以降の画像を確認しcntの値を決める
If r >= cnt Then
    cnt = r + 1
End If

'画像を検索する為のプロシージャへ飛ぶ
Call serchPicture(path, cnt)

Application.ScreenUpdating = True
    
End Sub

１点ポイントです。この作業を忘れない様にしてください。

'++++++++++++++++++++++++++++++++++++++++++++
Sub serchPicture(ByRef path As String, ByRef ct As Long)

'********************************************
Dim buf As String 'ファイル名を格納する為の変数
Dim flr As Object 'フォルダを格納する為の変数
Dim rng As Range '画像を貼るセルを格納する為の変数
Dim fso As Scripting.FileSystemObject 'ファイルシステムオブジェクトを格納する為の変数
Set fso = New Scripting.FileSystemObject  '変数にファイルシステムオブジェクトを格納する
'********************************************

'引数にあうファイルがあった時は変数bufに値を格納
buf = Dir(path & "\*." & Range("H5"))

'変数bufに値があるときはループに入る
'bufに値が入らなければループが終わる様になっている
Do While buf <> ""
    '指定した拡張子だったら対象のセルを決めてgetPictureへ飛ぶ
    If UCase(buf) Like "*." & UCase(Range("H5").Value) Then
        Set rng = Cells(ct, 1)
        Call getPicture(path, buf, rng)
        '戻ってきたら変数ctを1つ送る (次の行が選択されるように準備)
        ct = ct + 1
        '対象フォルダ内にある別のファイルを選択
    End If
        buf = Dir()
Loop

'指定のパス内にあるフォルダをループする
For Each flr In fso.getfolder(path).SubFolders
    '変数flrで確保されたフォルダのパス等を持って再帰に入る
    Call serchPicture(flr.path, ct)
Next

End Sub
'++++++++++++++++++++++++++++++++++++++++++++
'++++++++++++++++++++++++++++++++++++++++++++
Sub getPicture(ByVal path As String, ByVal buf As String, ByVal rng As Range)

'このプロシージャは自身の記事内のコードを転用しているので説明省略

With rng.Worksheet.Shapes.AddPicture _
    (Filename:=path & "\" & buf, _
    LinkToFile:=False, _
    SaveWithDocument:=True, _
    Left:=rng.Left, _
    Top:=rng.Top, _
    Width:=0, _
    Height:=0)
                                                       
    .LockAspectRatio = True
    .Placement = xlMoveAndSize
    
    .ScaleHeight 1, msoTrue
    .ScaleWidth 1, msoTrue
    
    If .Width > rng.Width - 2 Then
        .Width = rng.Width - 2
    End If

    If .Height > rng.Height - 2 Then
        .Height = rng.Height - 2
    End If

    .Top = .Top + ((rng.Height - .Height) / 2)
    .Left = .Left + ((rng.Width - .Width) / 2)
    rng.Offset(0, 1) = buf
End With

End Sub
'++++++++++++++++++++++++++++++++++++++++++++
'++++++++++++++++++++++++++++++++++++++++++++
Sub rowsCount(ByRef rw As Long)

'********************************************
Dim shp As Shape  '画像などの図形全般を格納する変数
'********************************************

'画像、図形の最終行を求める
For Each shp In ActiveSheet.Shapes
    '入力規則のリストがShape扱いになるので除外する為のループ
    If Not shp.Name Like "Drop Down *" Then
        '結果としてドロップダウンリスト以外のShapeがいる行番号が取得される
        rw = Application.Max(rw, shp.BottomRightCell.Row)
    End If
Next

End Sub
'++++++++++++++++++++++++++++++++++++++++++++

最後は削除ボタンのコードです。画像と画像名を削除する為のプロシージャです。

Sub clearPicture()

'********************************************
Dim myRng As Range  '画像を消す範囲を指定
Set myRng = Range("A:A")  '変数myRngはオブジェクトなのでSetが必要
Dim sp As Variant  '画像を取得する為の変数
Dim r As Long
'********************************************

Application.ScreenUpdating = False

'アクティブシート内のシェイプ（画像）を順番にループしていく
For Each sp In ActiveSheet.Shapes
'入力規則のリストがShape扱いになるので除外する為のループ
  If Not sp.Name Like "Drop Down *" Then
  'Intersectメソッドで変数myRangeと順番に選択したシェイプが重なっているか確認
    If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then
      'A列にかかっている画像は消す
      sp.Delete
    End If
  End If
Next
    
'変数myRngの開放
Set myRng = Nothing

'B列の最終行を取得
r = Cells(Rows.Count, 2).End(xlUp).Row
'B列の情報を削除
If r > 7 Then
  Range(Cells(8, 2), Cells(r, 2)).ClearContents
End If
    
Application.ScreenUpdating = True

End Sub

これで準備はOKです。

コード実行後の様子

解説

5つのプロシージャ毎にポイントを絞って解説します。

上の階層に戻ってきたり横の階層に移るために再帰処理が活躍しています。

main

このプロシージャが実行ボタンに連動しています。やっている事は2つです。

serchPicture

Dir関数について解説VBA｜Dir関数を使ってフォルダ内の複数ファイルを順番に処理する

該当のデータが存在する時

該当データが存在しない時

変数bufに値が入らない時はFor Eachステートメントに移動します。

getPicture

この中の処理はこちらの記事で使ったコードを転用しています。

合わせて読んでくださいVBAで画像を取り込む高速で画像自体を取得しエクセルに貼り付ける

VBAで画像を取り込む高速で画像自体を取得しエクセルに貼り付ける

「一定条件のもとフォルダから画像を取り出してエクセルに貼り付けるマクロを作りたい」の続編。900枚の画像処理は3秒で完了。2度手間は解消、0.1秒のウエイトは無しでも安定稼働します。キーはAddpictureメソッドです。

www.slt-pgming-21.net

2024.03.31

このコードへ「B列に画像名を並べるという」作業を追加しています。

rowsCount

入力規則のリストもShapeオブジェクト

実行、削除ボタンもShapeオブジェクトですが実行には影響が無いのであえて回避していません。

clearPicture

このプロシージャが削除ボタンに連動しています。やっている事は2つです。

画像の削除についてはこちらの記事でも使用しています。

関連記事VBAで画像を取り込むフォルダを周回必要な画像をエクセルに貼り付け

VBAで画像を取り込むフォルダを周回必要な画像をエクセルに貼り付け

複数フォルダ内の画像をキーワードを元にエクセルに貼り付ける方法を紹介　「一定条件のもとフォルダから画像を取り出しエクセルに貼り付けるマクロを作りたい」という依頼に対して作業をしてみました。

www.slt-pgming-21.net

2023.12.07

キーになるコード

serchPictureプロシージャ全般です。再帰呼び出し（処理）の3要件が詰まっています。

まとめ

EnjoyExcel