人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

ExcelのVBA:フォルダ内の大量画像から商品表作成を次の条件で自動化できませんでしょうか?

・メインフォルダの中にサブフォルダがあり、1週目_aa商店 2週目_aa商店・・・
1週目_bb商店 2週目_bb商店・・・ とフォルダ名がついている
・サブフォルダの中には大量の画像ファイルがあり、コード1_コード2
とファイル名がついている
・商品表シートには、A列:ファイル名(コード1_コード2) B列:画像サイズ
C列:商品名1 D列:商品名2 E列:商店名 F列:画像 G列:1週目
H列:2週目 I列:3週目 J列:4週目 K列:5週目 の項目になっている
・別シートには、コード1、商品名1、商品名2の一覧表がある

自動化したいのは、A列にはファイル名(拡張子は不要)を、B列には画像サイズを、C列、D列には一覧表から一致した、商品名1、商品名2を、E列にはフォルダ名から商店名部分を、F列には画像を、G列以降は、フォルダ名を参照して○をつけたい。
また2週目3週目で画像ファイルに重複があれば、2週目3週目に○だけをつけたい。

内容次第ではポイントプラスも考えています。よろしくお願いします。


●質問者: にゃんころね
●カテゴリ:コンピュータ 学習・教育
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● Mook
●500ポイント ベストアンサー

とりあえずのサンプルです。

商店+ファイル名 が一致するデータは1行にまとめるようにしています。
商品表シートは一度クリアしてから作成するようにしています。
消えて困る場合は、実行前にシートをコピー退避してから実行してください。

'//------------------------------------------------------------------------------
Option Explicit
'//------------------------------------------------------------------------------

'//------------------------------------------------------------------------------
Public Const 画像サイズ縦 = 80
Public Const 画像サイズ横 = 16

'//------------------------------------------------------------------------------
Sub リスト作成()
'//------------------------------------------------------------------------------
  '//--------------------
  '// ★ 対象フォルダ
  '//--------------------
 Const メインフォルダ = "C:\メインフォルダ"
 
 
  '//--------------------
  '// ★ VBE の「ツール」 ⇒「参照設定」で「Microsoft Scripting Runtime」をチェック
  '//--------------------
 Dim fso As New Scripting.FileSystemObject
 Dim dic As New Scripting.Dictionary
 
  '//--------------------
  '// 一覧データの読込
  '//--------------------
 DimAs Long
 With ThisWorkbook.Worksheets("商品一覧")
 For= 1 To .Cells(Rows.Count, "A").End(xlUp).Row
 If .Cells(, "A").Value <> "" Then
 dic(CStr(.Cells(, "A").Value)) = Array(.Cells(, "B").Value, .Cells(, "C").Value)
 End If
 Next
 End With
 
  '//--------------------
  '// 集計処理
  '//--------------------
 Dim 集計シート As Worksheet
 Set 集計シート = ThisWorkbook.Worksheets("仕入れ商品表")
 
 Dim sh As Shape
 集計シート.Cells.Clear
 For Each sh In 集計シート.Shapes
 sh.Delete
 Next
 集計シート.Range("A1:L1") = Array("ファイル", "画像サイズ", "商品名1", "商品名2", "商店名", "画像", _
 "1週目", "2週目", "3週目", "4週目", "5週目", "不明")
 
 集計シート.Columns("F").ColumnWidth = 画像サイズ横
 Dim サブフォルダ As Scripting.Folder
 Dim ファイル As Scripting.File
 DimAs String
 Dim ファイル名 As String
 Dim 商品コード As String
 Dim 商店名 As String
 Dim 検索行 As Long
 For Each サブフォルダ In fso.GetFolder(メインフォルダ).SubFolders
 If InStr(サブフォルダ.Name, "週目_") > 0 Then= Split(サブフォルダ.Name, "_")(0)
 商店名 = Split(サブフォルダ.Name, "_")(1)
 For Each ファイル In サブフォルダ.Files
 If InStr(ファイル.Name, "_") > 0 Then
 商品コード = Split(ファイル.Name, "_")(0)
 ファイル名 = Left(ファイル.Name, InStr(ファイル.Name, ".") - 1)= 集計シート.Cells(Rows.Count, "A").End(xlUp).Row
 For 検索行 = 2 ToIf 集計シート.Cells(検索行, "A").Value = ファイル名 And 集計シート.Cells(検索行, "E").Value = 商店名 Then Exit For
 Next
 If 集計シート.Cells(検索行, "A").Value <> ファイル名 Then= 集計シート.Cells(Rows.Count, "A").End(xlUp).Row + 1
 集計シート.Rows().RowHeight = 画像サイズ縦
 集計シート.Cells(, "A").Value = ファイル名
 集計シート.Cells(, "B").Value = ファイル.Size
 商品コード = Split(ファイル.Name, "_")(0)
 If dic.Exists(商品コード) = True Then
 集計シート.Cells(, "C").Value = dic(商品コード)(0)
 集計シート.Cells(, "D").Value = dic(商品コード)(1)
 End If
 集計シート.Cells(, "E").Value = 商店名
 画像リンク挿入 ファイル.Path, 集計シート.Cells(, "F")
 End If
 Select Case StrConv(, vbNarrow)
 Case "1週目": 集計シート.Cells(, "G").Value = "○"
 Case "2週目": 集計シート.Cells(, "H").Value = "○"
 Case "3週目": 集計シート.Cells(, "I").Value = "○"
 Case "4週目": 集計シート.Cells(, "J").Value = "○"
 Case "5週目": 集計シート.Cells(, "K").Value = "○"
 Case Else: 集計シート.Cells(, "L").Value = "○"
 End Select
 End If
 Next
 End If
 Next
End Sub

'//------------------------------------------------------------------------------
Sub 画像リンク挿入(画像パス As String, リンクセル As Range)
'//------------------------------------------------------------------------------
 リンクセル.Parent.Activate

 Dim picShape As Shape
 Set picShape = ActiveSheet.Shapes.AddPicture( _
 Filename:=画像パス, LinkToFile:=True, SaveWithDocument:=False, _
 Left:=リンクセル.Left + 1.5, Top:=リンクセル.Top + 1.5, _
 Width:=0, Height:=0)
 
 picShape.ScaleHeight 1, msoTrue
 picShape.ScaleWidth 1, msoTrue

 Dim cWidth
 Dim cHeight
 cWidth = リンクセル.Width - 3
 cHeight = リンクセル.Height - 3

 If (cWidth / picShape.Width) < (cHeight / picShape.Height) Then
 picShape.Height = picShape.Height * (cWidth / picShape.Width)
 picShape.Width = cWidth
 Else
 picShape.Width = picShape.Width * (cHeight / picShape.Height)
 picShape.Height = cHeight
 End If
End Sub


画像をオリジナルサイズにして、余白を設定した例です。
画像の横幅が全部同じなら、均等に余白があくかと思います。

'//------------------------------------------------------------------------------
Option Explicit
'//------------------------------------------------------------------------------

'//------------------------------------------------------------------------------
Sub リスト作成()
'//------------------------------------------------------------------------------
  '//--------------------
  '// ★ 対象フォルダ
  '//--------------------
 Const メインフォルダ = "C:\メインフォルダ"
 
 
  '//--------------------
  '// ★ VBE の「ツール」 ⇒「参照設定」で「Microsoft Scripting Runtime」をチェック
  '//--------------------
 Dim fso As New Scripting.FileSystemObject
 Dim dic As New Scripting.Dictionary
 
  '//--------------------
  '// 一覧データの読込
  '//--------------------
 DimAs Long
 With ThisWorkbook.Worksheets("商品一覧")
 For= 1 To .Cells(Rows.Count, "A").End(xlUp).Row
 If .Cells(, "A").Value <> "" Then
 dic(CStr(.Cells(, "A").Value)) = Array(.Cells(, "B").Value, .Cells(, "C").Value)
 End If
 Next
 End With
 
  '//--------------------
  '// 集計処理
  '//--------------------
 Dim 集計シート As Worksheet
 Set 集計シート = ThisWorkbook.Worksheets("仕入れ商品表")
 
 Dim sh As Shape
 集計シート.Cells.Clear
 For Each sh In 集計シート.Shapes
 sh.Delete
 Next
 集計シート.Range("A1:L1") = Array("ファイル", "画像サイズ", "商品名1", "商品名2", "商店名", "画像", _
 "1週目", "2週目", "3週目", "4週目", "5週目", "不明")
 
 Dim サブフォルダ As Scripting.Folder
 Dim ファイル As Scripting.File
 DimAs String
 Dim ファイル名 As String
 Dim 商品コード As String
 Dim 商店名 As String
 Dim 検索行 As Long
 For Each サブフォルダ In fso.GetFolder(メインフォルダ).SubFolders
 If InStr(サブフォルダ.Name, "週目_") > 0 Then= Split(サブフォルダ.Name, "_")(0)
 商店名 = Split(サブフォルダ.Name, "_")(1)
 For Each ファイル In サブフォルダ.Files
 If InStr(ファイル.Name, "_") > 0 Then
 商品コード = Split(ファイル.Name, "_")(0)
 ファイル名 = Left(ファイル.Name, InStr(ファイル.Name, ".") - 1)= 集計シート.Cells(Rows.Count, "A").End(xlUp).Row
 For 検索行 = 2 ToIf 集計シート.Cells(検索行, "A").Value = ファイル名 And 集計シート.Cells(検索行, "E").Value = 商店名 Then Exit For
 Next
 If 集計シート.Cells(検索行, "A").Value <> ファイル名 Then= 集計シート.Cells(Rows.Count, "A").End(xlUp).Row + 1
 集計シート.Rows().RowHeight = 画像サイズ縦
 集計シート.Cells(, "A").Value = ファイル名
 集計シート.Cells(, "B").Value = ファイル.Size
 商品コード = Split(ファイル.Name, "_")(0)
 If dic.Exists(商品コード) = True Then
 集計シート.Cells(, "C").Value = dic(商品コード)(0)
 集計シート.Cells(, "D").Value = dic(商品コード)(1)
 End If
 集計シート.Cells(, "E").Value = 商店名
 画像リンク挿入 ファイル.Path, 集計シート.Cells(, "F")
 End If
 Select Case StrConv(, vbNarrow)
 Case "1週目": 集計シート.Cells(, "G").Value = "○"
 Case "2週目": 集計シート.Cells(, "H").Value = "○"
 Case "3週目": 集計シート.Cells(, "I").Value = "○"
 Case "4週目": 集計シート.Cells(, "J").Value = "○"
 Case "5週目": 集計シート.Cells(, "K").Value = "○"
 Case Else: 集計シート.Cells(, "L").Value = "○"
 End Select
 End If
 Next
 End If
 Next
End Sub

'//------------------------------------------------------------------------------
Sub 画像リンク挿入(画像パス As String, リンクセル As Range)
'//------------------------------------------------------------------------------
 リンクセル.Parent.Activate

 Dim picShape As Shape
 Set picShape = ActiveSheet.Shapes.AddPicture( _
 Filename:=画像パス, LinkToFile:=True, SaveWithDocument:=False, _
 Left:=リンクセル.Left + Application.CentimetersToPoints(0.2), _
 Top:=リンクセル.Top + Application.CentimetersToPoints(0.2), _
 Width:=0, Height:=0)
 
 picShape.ScaleHeight 1, msoTrue
 picShape.ScaleWidth 1, msoTrue

 If リンクセル.Height < (picShape.Height + Application.CentimetersToPoints(0.4)) Then
 リンクセル.EntireRow.RowHeight = picShape.Height + Application.CentimetersToPoints(0.4)
 End If

 If リンクセル.Width < (picShape.Width + Application.CentimetersToPoints(0.4)) Then
 リンクセル.EntireColumn.ColumnWidth = picShape.Width + Application.CentimetersToPoints(0.4)
 End If
End Sub

にゃんころねさんのコメント
追記して頂いたコード、まだ試しておりませんが、ご丁寧にありがとうございました。 ポイントプラスにする事ができませんでしたので、次回の際に考慮させてください。

質問者から

コードを動作させてみました。さらに3点希望があります。
1.1週目、2週目・・・ のフォルダに同名のファイルがある場合は、
1週目 2週目 3週目
○ ○
○ ○
となるようにしたいです。
2.画像をセルにおさめる時、画像の高さに合わせて行の高さを同じにしたいです。
3.画像とセルの間、上下左右に余白を2mm程度にしたいのです。

よろしくお願いします。


関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ