複数フォルダ内の画像をキーワードを元にエクセルに貼り付ける
表題の様な依頼をいただきました。VBAでも画像を扱う事が出来ます。
ただしネット記事などを探しても事例が少なく勉強する事が難しいです。
今回は写真を含めた画像の取り回しにおいて私自身が試行錯誤した模様を紹介します。
事例を紹介する事で同じ様な案件で困っている方の助けになれば良いなと思っています。
この記事を見るとフォルダ内から好きな画像をエクセルに持ってくることができる様になります。
画像の扱いに加えて階層構造を持ったフォルダへのアクセス方法についても勉強出来ますよ。
関連記事
今回の記事ではご依頼に対して検討用で作成したコードを紹介します。
次の記事では今回のコードをグレードアップさせています。
次回記事のコードは今回のコードより短い、かつ作業スピードが格段に上がっています。
今回のコードを書き直した記事はこちらです。
こちらはさらにレベルアップしたコードを掲載しています。
再帰呼び出しを使う事で階層の異なるフォルダ群から画像をもれなく取り出すというコードを用意しています。
この本で勉強しました
階層構造をもつフォルダ内を巡回する方法を勉強する為の教材を探すのは非常に難しいです。
理由は単純です。参考文献が少ない為です。
資料を探し出したとしても理解できないとご自身のコードに活かす事はできません。
私はこの本で勉強しました。
84ページから始まる「COM/OLEを利用しよう」がおすすめです。
CreateObject関数の考え方、使い方が分かる様になります。
ポチップ
電子書籍はこちらです。
案件の概要
まずお話を聞かせていただきました。
一定条件のもとフォルダから画像を取り出しエクセルに貼り付けるマクロを作りたい
という依頼です。抽象的なところもありますのでもう少し具体的に話を聞いてみます。
案件の詳細
事前打合せである程度やりたい事は聞くことが出来ました。
- エクセルファイルを起点にする（最終的にエクセルに画像を貼る）
- 複数のフォルダ内の画像を取得しエクセルに順番に貼り付けたい
- フォルダの中にフォルダというかたちで階層構造がある
- 末端の各フォルダに画像ファイルが居る
- 画像ファイルは約900枚
- 画像ファイルの拡張子（jpg、png等）は聞き忘れました
- 画像はファイル名に一定のキーワードをもっている
- 画像名に特定のキーワードを含む画像だけエクセルに持ってくる
- 画像挿入規則（並べ方）はセル内 飛び地ではなくある程度連続で貼り付ける様子
ざっとですが上記のような事がやりたいそうです。
情報収集
早速データを用意してみました。
ActiveSheet.picture.Insert(引数)・・・ というコードを見つける事が出来ました。
このコードで画像を取得すると画像ではなく「画像リンク」を取得する事が出来ます。
画像リンクのままだと以下の様なデメリットがあるのでひと手間対策が必要との事でした。
画像リンクは扱い辛い
画像リンクのままでもデータを取得した方のPCでは画像が表示されます。
しかし他者にデータを転送する等リンクパスが切れた環境では画像がエラーで見れない様です。
よって一度取り込んだリンクを再度選択しカット＆ペーストする必要があります。
これでリンクした画像ではなくあくまで画像単体として貼り直す必要がある様です。
要するにリンク切れをおこさない様に対策する必要があるとの事でした。
手間がかかりそうなコードだなという印象です。
コードを書く＆テストしてみる
まずはやってみる事にします。テスト環境を用意しました。
作業環境
今回作成したエクセルとフォルダの関係です。
- 1つのフォルダの中に10個のフォルダを用意
- 各フォルダ内にランダムに画像をセット
- 画像名もランダムにキーワードをセット
- TOTALで450枚程度の画像を用意
エクセルからグレーのフォルダに一旦アクセスします。
その後フォルダと画像を周回しながらキーワードに合致した画像をエクセルに取ってくるという仕様です。
エクセルの画像です。セルの幅等ワークシートの環境を整備し実行ボタンと解除ボタンを作成。
プログレスバーを用意します
作業の進捗状況を表示させるプログレスバーです。作ったのは理由があります。
作業時間がかかる為途中でマクロが止まってないか確認したくなり用意した次第です。
プログレスバーが動いているうちは作業が止まってない事が分かります。
プログレスバーについて興味ある方はこちらの記事もご覧ください。動画で稼働状況が分かります。
コード
ここからはコードを紹介です。まずはメインのプロシージャです。
Option Explicit
Sub 案件1_実行()
'◆作業の流れ
'エクセルを開く
'セルA3にフォルダパスを書く
'実行ボタンを押す
'対象フォルダ内のフォルダを1つずつ掴む
'フォルダ内の画像を周回しデータ名に _get があったら画像をエクセルに貼り付ける
'繰り返し
'ポイントは作業内のコメントを参照ください
'◆進捗管理
'件数が多くなる可能性もあるのでプログレスバーを用意した
'プログレスバーの分母は別プロシージャのGetFolderCountで獲得
'***********************************************
'変数の型を宣言
Dim base_path As String 'ファイルパスを格納 セルA3の値に￥をつけるための変数
Dim file_name As String 'ファイル名を格納
Dim file_path As String '上2つの変数をセットにしたもの
Dim i As Integer: i = 2 ' 貼付け位置を管理する変数
Dim FSO As Object ' ファイルシステムオブジェクト フォルダを扱う為の変数
Dim s_fd As Object '現状掴んでるフォルダを格納する変数
Dim count As Long 'プログレスバーの分母を格納
Dim percent As Integer 'プログレスバーの作業進捗率を格納
Dim t As Long 'プログレスバーの値を計算する為の変数
'***********************************************
'画面更新を止める（少しでも作業を減らして速度を上げる為）
Application.ScreenUpdating = False
'***********************************************
Call GetFolderCount(count)
'プログレスバーFormを表示
UserForm1.Show vbModeless
UserForm1.StartUpPosition = 0
UserForm1.Top = 220
UserForm1.Left = 550
'プログレスバーの最小値を設定
UserForm1.ProgressBar1.Min = 1
'プログレスバーの最大値を設定
UserForm1.ProgressBar1.Max = count
'プログレスバーの現在値を設定
UserForm1.ProgressBar1.Value = 1
'アイコンを待機中に固定
Application.Cursor = xlWait
'***********************************************
'ファイルシステムオブジェクトはオブジェクトなのでSetが必要
Set FSO = CreateObject("Scripting.FileSystemObject")
'セルA3に書いてあるパスに存在するフォルダの中に居るフォルダを順番に選択
For Each s_fd In FSO.GetFolder(Cells(3, 1)).SubFolders
'file_pathを作る為の準備
base_path = s_fd & "\"
file_name = Dir(base_path, vbNormal)
file_path = base_path & file_name
'変数file_nameが無くなるまでループします
Do Until file_name = ""
'変数file_nameの中に _get が居るか？
If file_name Like "*_get*" Then
'_getが居たら以下処理
'一旦シートに画像を貼り付ける
ActiveSheet.Pictures.Insert(file_path).Select
'続いてその画像をカット
Selection.Cut
'貼付けしたいセルを選択
Cells(i + 3, 1).Select
'セルに貼付け
ActiveSheet.PasteSpecial
'高さを調整
Selection.ShapeRange.Height = 100
'変数iを1つ送る（セルを1つ送る）
i = i + 1
'0.1秒待つ。1004対策。これでエラーが起きない。
Application.Wait [Now() + "0:00:00.1"]
End If
'Dir関数でファイル内に居る次のファイルを掴む
'ファイル名を変数file_nameにセット
file_name = Dir()
'変数file_pathに次のファイル名をセットする
file_path = base_path & file_name
'Doまで戻る
Loop
'***********************************************
If UserForm1.IsCancel = True Then
'プログレスバーFormを閉じる
Unload UserForm1
'マウスカーソルをデフォルトに戻す
Application.Cursor = xlDefault
'途中までの結果は無しにして処理を終了。
MsgBox "作業中ですが本作業を終了します", , "作業をキャンセルしました"
End
End If
'プログレスバーの値表示を更新
If UserForm1.ProgressBar1.Min < t And _
UserForm1.ProgressBar1.Max >= t Then
'プログレスバーのLabel表示を更新
percent = CInt(t / count * 100)
UserForm1.Label1.Caption = percent & "%完了"
'プログレスバーの値を更新
UserForm1.ProgressBar1.Value = t
'滞留処理を実行
DoEvents
End If
t = t + 1
'***********************************************
Next s_fd
Unload UserForm1
'マウスカーソルをデフォルトに戻す
Application.Cursor = xlDefault
MsgBox "処理が完了しました", , "作業完了"
'***********************************************
'画面更新を元に戻す
Application.ScreenUpdating = True
'***********************************************
End Subプログレスバー（フォーム）で進捗率の分母を取得するためのプロシージャです。
Private Sub GetFolderCount(count)
'プログレスバーの分母を決める為に対象フォルダ内のフォルダ数をカウントするプロシージャ
'フォルダ数が分母になるのでフォルダ内のデータ数に偏りがあるとバーの進み具合がスムーズではないところが出る可能性有
'本質は作業が進んでいるかの確認なので進み具合のばらつきは考えないようにする
'***********************************************
Dim TargetDir As String '対象フォルダのパスを格納 セルA3
Dim SubCount As Long 'フォルダ数を格納
'***********************************************
TargetDir = Range("A3")
With CreateObject("Scripting.FileSystemObject")
SubCount = .GetFolder(TargetDir).SubFolders.count
End With
'単純にフォルダ数をカウントして変数countに値をセット。メインのプロシージャに値を返すだけ
count = SubCount
End Subプログレスバー（フォーム）に書くコード ・・・ 変数（IsCancel）の宣言と2つのプロシージャです。
Option Explicit
'キャンセル処理用フラグ
Public IsCancel As Boolean
'初期化
Private Sub UserForm_Initialize()
'キャンセルフラグにFalseを設定
IsCancel = False
End Sub
'キャンセルボタンクリックイベント
Private Sub BtnCancel_Click()
'キャンセルフラグにTrueを設定
IsCancel = True
End Sub取得した画像を削除するためのプロシージャです。
Sub 案件1_削除()
'◆画像を消すコード
'ポイントは作業内のコメントを参照ください
'***********************************************
'変数の定義
Dim myRng As Range '画像を消す範囲を指定
Set myRng = Range("A1:A1000") '変数myRngはオブジェクトなのでSetが必要
Dim sp As Variant '画像を取得する為の変数
'***********************************************
'画面更新を止める（少しでも作業を減らして速度を上げる為）
Application.ScreenUpdating = False
'***********************************************
'アクティブシート内のシェイプ（画像）を順番にループしていく
For Each sp In ActiveSheet.Shapes
'Intersectメソッドで変数myRangeと順番に選択したシェイプが重なっているか確認
If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then
'重なっていたら消す 変数myRangeはA列の1～1000なのでこの範囲にかかっている画像は消す
sp.Delete
'実行ボタンと削除ボタンが消えないのはA1～A1000にかかってないからです
End If
Next sp
'変数myRngの開放
Set myRng = Nothing
'***********************************************
'画面更新を止める を解除
Application.ScreenUpdating = True
'***********************************************
End Subテスト結果
コードは動く様になったのですが3つ気になるところが残りました。
- 画像を貼り替えているので2度手間
- ループで処理を回すと何故かエラーが出る
- 単純に遅い
もう少し具体的に書き出します。
2度手間
1回で画像を持ってくるというコードではないので2度手間なコードです。
この時点ではもう我慢するのみでした。本当は根本的にコードを変える必要があります。
コードを書き換えた記事は冒頭にリンクを用意しています。こちらから戻る事が出来ます。
エラー対策
コードは間違ってないのに実行中に貼付けが出来ないというエラーが出ます。
エクセルに画像を数枚貼り付けたところで決まって実行時エラー1004のダイアログ画面が立ち上がります。
ステップイン（F8）で確認するとエラーは出ないので何故か分かりません。
不具合解析は経験が必要です
他のプログラミング言語で書かれたコードによる作業の中でこんな事がありました。
同じコードでエラーが出るPCとエラーが出ないPCがあるという事例です。
原因としてはPCのスペックや並行稼働しているアプリケーションの差でエラーが起きる事が分かりました。
具体的に言うとコードの実行にブラウザやサーバーのデータが追いついてこなくてエラーになっていました。
コードが先行しない様にコード内に待ち時間を設定する事でPC全体の歩調を合わせるという対策をとりました。
待ち時間といってもループの中で1秒程度です。
それでどのPCでもエラーが出なくなりました。そのことを思い出しました。
不具合事例は他の事例にも当てはまる事がある
デバッグで問題無いならコード以外に問題があると考えました。
過去の事例から試せるものを試した次第です。
結果的にはこれがうまくいく事になります。
ループの中で1秒程度作業を止めてみたところマクロは安定して稼働してくれました。
エラーも起きない様です。ただし1秒は長いので何回かテストし最終的に0.1秒まで削りました。
作業は止まらず安定するのでこれで進める事にしました。
作業が遅い
テストしたところ450枚の画像から約300枚ぐらいをエクセルに取り出すと約50秒程度かかります。
実際の環境は約900枚の画像があると聞いていたので100秒以上時間がかかる事になります。
仕方ないので進捗が分かる様にする為にプログレスバーを付ける様にしました。
まとめ
依頼者様に確認を取りOKをもらいました。
数日後コードを紹介する為に勉強会を開催する事にしました。
しかし自分の中で納得がいかない気持ちが大きくなりどうしてもコードをメンテナンスしたくなりました。
一番大きいのは2度手間となっている作業です。
「これを止めれば作業時間も短縮出来る」事が分かっているのに上手く収める事が出来ていませんでした。
次回記事で説明しますが試行錯誤したところ不具合は改善できました。
2度手間は無くなり作業時間は劇的に改善される事になります。成果は以下の通りです。
- 画像900枚で計100秒の作業時間は3秒程になる
- プログレスバーが不要となる
- 0.1秒の待ち時間も止め
- コードも短くなりスッキリした
依頼者様からOKいただきましたので記事掲載します。上記赤文字の内容を含んだ内容となっています。
ボタンからブログリンクに移動出来ます。（本記事冒頭のへのリンクです）
オンライン講座の紹介
自身で無料の説明会に参加してきました。良かった事、気になった事をまとめています。
マクロを勉強したい方やイチから勉強をやり直したい方におすすめのコンテンツです。
