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人5回まで
  • 13歳以上
  • 登録:2014/01/19 00:26:02
  • 終了:2014/01/26 00:30:04

ベストアンサー

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912014/01/22 21:45:19

ポイント500pt

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

商店+ファイル名 が一致するデータは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
id:sunfkin22

追記して頂いたコード、まだ試しておりませんが、ご丁寧にありがとうございました。

ポイントプラスにする事ができませんでしたので、次回の際に考慮させてください。

2014/01/26 01:16:59

その他の回答(0件)

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912014/01/22 21:45:19ここでベストアンサー

ポイント500pt

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

商店+ファイル名 が一致するデータは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
id:sunfkin22

追記して頂いたコード、まだ試しておりませんが、ご丁寧にありがとうございました。

ポイントプラスにする事ができませんでしたので、次回の際に考慮させてください。

2014/01/26 01:16:59
id:sunfkin22

○については自己解決しました。

1.画像をセルにおさめる時、画像の高さに合わせて行の高さを調整したいです。
※幅は200ピクセルで一定ですが、高さはばらばらです。
2.画像とセルの隙間、上下左右に余白を2mm程度入れたいのです。

よろしくお願いします。

  • id:Mook
    それぞれのシート名と、別シートのコードと商品名の構成(列)はどうなっているのでしょう。
  • id:sunfkin22
    シート名は、「仕入れ商品表」と「商品一覧」になります。
    また、別シートのコードは、頭が!+8桁のランダムな半角英数字(計9桁です。
    商品名の構成は、A列:コード1 B列:商品名1 C列:商品名2となります。
    A列:!CE9767CA B列:りんご C列:紅玉 といった感じになります。

    よろしくお願いします。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません