より簡単かつ高速にエクセルに画像を取得出来るコードを紹介
ある依頼をもとにエクセルで画像を扱う為のコードを用意しました。
フォルダから複数の画像（写真）を取り出してエクセルに貼り付けるマクロを作りたい
一度コードを書いてみたのですが様々な課題があり稼働状態も安定しませんでした。
試行錯誤したところ使い勝手が良いコードが見つかりましたので紹介します。
今回の記事では数秒の内にフォルダ内から画像（写真）を集めてきますよ。
加えて画像貼り付け時（挿入時）の大きさはセルの幅を変えるだけで調整できる様にしました。
マクロが書けない人でも画像の大きさを変える事ができます。
前回記事
あるフォルダの中から画像を持ってくる為のコードを書いてみました。
しかし色々と納得がいかない事があり試行錯誤したという内容の記事です。
前回記事で用意したコードの問題点は以下のとおりです。
- 画像を貼り替えているので2度手間
- ループで処理を回すと何故かエラーが出る
- 単純に遅い
きっちり改善させました。
この本で勉強しました
階層構造をもつフォルダ内を巡回する方法は参考になるコードを探すのが難しいです。
私はこの本を使って勉強しました。
CreateObject関数の考え方、使い方が分かる様になります。
ポチップ
電子書籍はこちらです。
関連記事
今回の記事は長いです。100行ほどのプロシージャになっています。
リンク先の記事は本記事に似たプロシージャを3つに分けて可読性とメンテナンス性（作業性）を上げています。
サブルーチンが分かるVBA｜コードが長いプロシージャを短く切り分ける｜マクロを部品化する
改善する為にコードを書き直しました
依頼者様と合意出来ていたのですが自分の興味もありますので再度調査をしてみる事にしました。
もし良いものが出来たらプラスで依頼者様に納品すれば良いと思いやってみる事にした次第です。
やってみると数分でさらに良さそうなコードを発見しました。
ワークシート
まずはワークシートの紹介です。ワークシートは前回記事のままです。
セルA3にTOPフォルダのパスを記入しています。あとは実行と削除ボタンです。
コード
結論から申し上げますと AddPictureメソッド が使えそう。
これなら2度貼りじゃないし引数で細かい指定も出来そうです。
画像の貼り付け方まで載っていたので拝借させていただき少しアレンジしました。
プロシージャの量としては多くなってしまいましたが出来るだけシンプルに書く様に調整しています。
Sub 案件1_改良_実行()
'1_変数の宣言
Dim base_path As String 'ファイルパスを格納 セルA3の値に￥をつけた
Dim file_name As String 'ファイル名を格納
Dim file_path As String '上2つの変数をセットにしたもの
Dim i As Long: i = 2 ' 貼付け位置を管理する変数
Dim FSO As Object ' ファイルシステムオブジェクト フォルダを扱う為の変数
Dim s_fd As Object '現状掴んでるフォルダを格納する変数
Dim rng As Range '貼り付けるセルを決める為の変数
'***********************************************
'2_画面更新をコントロール（少しでも作業を減らして速度を上げる為）
Application.ScreenUpdating = False
'***********************************************
'3_フォルダ周回用のループを作成
'ファイルシステムオブジェクトはオブジェクトなので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
'4_ファイル名のキーワードを確認
'変数file_nameが無くなるまでループします
Do Until file_name = ""
'変数file_nameの中に _get が居るか？
If file_name Like "*_get*" Then
'5_画像を貼りつけるセルを変数rngにセット
Set rng = Cells(i + 3, 1)
'6_画像を取得する
'AddPictureメソッドを使う
'1回引数を指定しないといけない
'LeftTopはセル起点、widthHeightはゼロで仮置き
With rng.Worksheet.Shapes.AddPicture(fileName:=file_path, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=rng.Left, _
Top:=rng.Top, _
Width:=0, _
Height:=0)
'Shapeプロパティへの処理
.LockAspectRatio = True '縦横比固定
.Placement = xlMoveAndSize '移動&サイズ変更
'縦を元のサイズを起点に100% = 元の画像と同じサイズ
.ScaleHeight 1, msoTrue
'横を元のサイズを起点に100% = 元の画像と同じサイズ
.ScaleWidth 1, msoTrue
'7_画像がセルの中心に配置される様に位置と大きさを調整
'画像のサイズがセルの「幅-2」より大きかったら・・・
If .Width > rng.Width - 2 Then
'画像の幅はセル「幅-2」に変更する
.Width = rng.Width - 2
End If
'画像のサイズがセルの「高さ-2」より大きかったら・・・
If .Height > rng.Height - 2 Then
'画像の幅はセル「高さ-2」に変更する
.Height = rng.Height - 2
End If
'画像をセル高さ方向の中心にセット
.Top = .Top + ((rng.Height - .Height) / 2)
'画像をセル幅方向の中心にセット
.Left = .Left + ((rng.Width - .Width) / 2)
End With
i = i + 1
End If
'8_次の画像を確認する為の処理
'Dir関数でフォルダ内に居る次のファイルを掴む
'ファイル名を変数file_nameにセット
file_name = Dir()
'変数file_pathに次のファイル名をセットする
file_path = base_path & file_name
'Doまで戻る
Loop
Next s_fd
'***********************************************
'2_画面更新を止める を解除
Application.ScreenUpdating = True
'***********************************************
'9_作業終了の報告
MsgBox "処理が完了しました", , "作業完了"
End Sub 削除ボタンは前回記事を参考にしてください。
コードの解説
コードの構成を用意しました。実際のコード内のコメントにふった番号と合わせてご覧ください。
- 1変数の宣言
使用する変数を宣言（定義)します
- 2画面更新をコントロール
作業中は画面更新を止めます。速度対策のみに書くコードです。
- 3フォルダ周回用のループを作成
CreateObject関数を使用します。
引数にはファイル関連の処理を可能にするScripting.FileSystemObjectを使用します。
- 4ファイル名のキーワードを確認
指定したキーワードが画像の名前に入っているのかを確認します。
Like演算子を使用しています。
- 5画像を貼りつけるセルを変数rngにセット
対象のセルを変数rngにセットします。
- 6画像を取得する
5番で指定したセルを起点に画像を持ってきます。
- 7画像がセルの中心に配置される様に位置と大きさを調整
条件分岐を使って指定のセルの中心に入る様に画像の位置、大きさを調整します。
大きさを調整してから最後に位置を調整します。
- 8次の画像を確認する為の処理
Dir関数でフォルダ内にある次の画像を掴みます。
- 9作業終了の報告
メッセージボックスで処理が完了したことを報告します。
AddPictureメソッドの後に配置された7番に関連するコードは画像の大きさを調整するパートです。
不要であれば消していただく事でコードがすっきりします。用途に応じて調整をお願いします。
キーになるコード
先程もお伝えしましたが AddPicture（引数） です。AddPictureはメソッドです。
余談ですがこのコードの前に変数rngが乗っかっている事にびっくりしました。
RangeオブジェクトがWorksheetプロパティを持っているんですね。
話をAddPictureメソッドに戻します。引数は以下リストを参照ください。
沢山ありますので引数を省略したくなるのですが書かないとエラーになります。ご注意ください。
| 番号 | 引 数 | 内 容 |
|---|---|---|
| 1 | Filename | 対象データのフルパス |
| 2 | LinkToFile | Trueでリンク、Falseで画像自体（独立したコピーを生成） |
| 3 | SaveWithDocument | Trueで画像として保存Falseでリンク情報を保存 |
| 4 | Left | 文書の左上隅を基準に対象データの左上隅の位置をポイントで指定 |
| 5 | Top | 文書の上端を基準に対象データの上端をポイントで指定 |
| 6 | Width | 対象データの横幅を指定 |
| 7 | Height | 対象データの高さ方向の幅を指定 |
パラメータのLinkToFileとSaveWithDocument
AddPictureメソッドの引数の中で分かりにくいのがこの2つの引数です。
共にTrueかFalseを指定するのですが組み合わせによってはエラーになります。
エラーの回避方法や全部の組み合わせを試した記事を用意したので必要に応じてご覧ください。
組み合わせを試した結果はマトリクスで一目で分かる様にしておきました。
アウトプット
セルA5から行方向に画像が入ります。
コードの7行目にある数値を変更すると開始位置を変えられます。
元の画像の縦横比を守りながらセルA5内に入る最大の画像がセットされています。
画像の大きさを変えるのも簡単です。セルの高さや幅を変える事で画像の大きさを変えられます。
コードを書き直す必要は無いです。これならコードが書けない人でも画像の大きさを変えられます。
前回記事からの改善点
気になっている事は全て改善されました。
- 2度手間は解消（画像リンクではなく最初から画像としてエクセルに取り込む為）
- 0.1秒のウエイトは無しでも安定稼働する
- 画像の位置はセル側でコントロールできる様にした（コードをメンテしない仕様）
- 作業時間が超絶速くなった
テスト環境で450枚の画像を使った時は2秒以下。900枚だと約3秒です。
作業時間はPCのスペックやエクセルと画像データの置き場所にもよります。
これを見た人が同じような作業時間になるかは分かりません。ご注意下さい。
私は同じPCで2つのコードを比較してみました。
エクセルと画像データが入ったフォルダをデスクトップに置いて作業しています。
環境を変えてTRYしてみる
環境を変えてみます。ローカルネットワーク環境に画像の入ったフォルダ群をセットしてみました。
画像を取得するエクセルを自PCに置いて速度のテストをしたところ7～8秒程度で作業完了しました。
多少遅くなりますが気になるほどではありません。
ネットワーク環境にもよりますがものすごく作業が遅くなることは無い様です。
上記の通り作業は数秒で終わるのでプログレスバーも止めました。
おかげでコードもスッキリです。
さらに出来る事を増やしました
「再帰呼び出し（再帰処理）を使って階層の違うフォルダ群から画像を取り出す」という記事です。
今回のコードよりさらに出来る事が増えています。是非ご覧ください。
「再帰呼び出しとは？」という記事も用意しています。
再帰が苦手な人や良く分からない方にも分かる様に画像と動画を用意しています。
初心者向け【ExcelVBA】再帰呼び出し（再帰処理）は3分の動画で理解できる
まとめ
依頼者様にはデータを納品しました。
- 最初に合意いただいたコード(作業時間が100秒かかるコード)
- 最終版(本記事の作業時間が3秒のコード)
- 取得した画像を消すコード
- プログレスバー用のサブプロシージャ
作業するにあたってこちらを見てもらえば効率が上がるのではと思い記事にしてみました。
他にも世の中の誰かに使ってもらえる機会があるかもしれません。
参考：関連記事
本シリーズはこちらの記事とも連携しています。