質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
85.50%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

Q&A

解決済

1回答

3747閲覧

複数のフォルダに入っている画像データをフォルダ毎にシート作成するマクロを作りたい

RS8

総合スコア26

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

0グッド

0クリップ

投稿2018/10/23 04:07

表題の通り、あるフォルダの直下に複数のフォルダがあり、その中にランダムな枚数、大きさで写真データが入っています。
写真が入っているフォルダが物件になるので、フォルダ単位でシートを作成してそこに写真を同じ大きさで張付けるマクロを作成したいと思い、色々ネット上を検索してみて、サブフォルダの写真を一括で1シートに並べる物は見つかったのですが、そこにどう追記をすれば良いのかがわかりません。
お力をお借りできればと思い書き込みさせてもらいました。
ソースは以下です。よろしくお願いします。

' 指定された親フォルダ内で,すべてのサブフォルダ内に存在する
' 画像のサムネイルのアルバムをシート上に作成します。
Sub CreateImgAlbum()

' 親フォルダのパス root_dir = "" ' フォルダ内のサブフォルダをスキャン Set fso = CreateObject("Scripting.FileSystemObject") Set sub_dirs = fso.GetFolder(root_dir).SubFolders y = 1 For Each sub_dir In sub_dirs ' このサブフォルダについて処理 y = importImagesFromOneSubDir(sub_dir, y, root_dir) Next ' 1列目の幅を自動調整 Rows(1).EntireColumn.AutoFit MsgBox "全サブフォルダの処理を終了"

End Sub

' ある一つのサブフォルダについての処理
Private Function importImagesFromOneSubDir(sub_dir, y, root_dir)
'MsgBox sub_dir.Name

' このフォルダ内の画像をすべて列挙 file_name = Dir(sub_dir & "*.*") Do While file_name <> "" ' このファイルの拡張子を調べる If isImageFile(file_name) Then ' 画像であれば,取り込んで次の行へ importImageFile file_name, y, root_dir, sub_dir y = y + 1 End If ' 次のファイルを取得 file_name = Dir() Loop ' 現在の行を返す importImagesFromOneSubDir = y

End Function

' 画像ファイルかどうか,拡張子で判定する
Private Function isImageFile(file_name)

' ピリオドは後ろから何文字目か pos_period = InStrRev(file_name, ".") If pos_period > 0 Then ' 拡張子を切り出し file_ext = LCase(Mid(file_name, pos_period + 1)) ' 画像の拡張子か?(小文字で指定可) If _ file_ext = "jpg" Or _ file_ext = "jpeg" Or _ file_ext = "bmp" Or _ file_ext = "gif" Or _ file_ext = "png" _ Then ' 画像であると判定 ret = True Else ret = False End If Else ret = False End If isImageFile = ret

End Function

' ある一つの画像ファイルをシート中に取り込む
Private Sub importImageFile(file_name, y, root_dir, sub_dir)
file_path = sub_dir & "" & file_name

ActiveSheet.Cells(y, 1).Select Set myShape = ActiveSheet.Shapes.AddPicture( _ Filename:=file_path, _ LinkToFile:=False, _ SaveWithDocument:=True, _ Left:=Selection.Left, _ Top:=Selection.Top, _ Width:=Application.CentimetersToPoints(10), _ Height:=Application.CentimetersToPoints(7)) ' この行高を自動調整 Cells(y, 1).RowHeight = Application.CentimetersToPoints(7.3)

End Sub

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

guest

回答1

0

ベストアンサー

ちゃんとMarkdownされていないので細かくはコードを読んでいませんが、フォルダ毎の処理が始まったところでシートを追加してあげるだけかと

VBA

1 ' ある一つのサブフォルダについての処理 2 Private Function importImagesFromOneSubDir(sub_dir, y, root_dir) 3 Worksheets.Add '← シート追加 4 ActiveSheet.Name = sub_dir '← シート名をサブフォルダ名に変更

どこに追加すれば良いか分からない時は、F8ステップ実行で各コードが何をしているか見ながら進めていけば、何処に追加すべきかはだいたい分かると思います。

投稿2018/10/23 04:29

退会済みユーザー

退会済みユーザー

総合スコア0

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

RS8

2018/10/23 06:15

回答ありがとうございます。 追記してみましたが、実行時エラー1004 シートの名前が正しくありませんと出てしまいます。 フォルダの名前を変更してみたり、ステップインしながら違う場所に何か所か記載して試みてみましたが、うまくいきません。
RS8

2018/10/23 06:20

すみません。sub_dir.nameにしたら上手くいきました。ありがとうございます。助かりました。
guest

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
85.50%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問