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

Question

にゃんころね

20

19もっと見る

500pt

コンピュータ学習・教育

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

・メインフォルダの中にサブフォルダがあり、１週目_aa商店　２週目_aa商店・・・
　１週目_bb商店　２週目_bb商店・・・　とフォルダ名がついている
・サブフォルダの中には大量の画像ファイルがあり、コード１_コード２
　とファイル名がついている
・商品表シートには、A列：ファイル名（コード１_コード２）　B列：画像サイズ
　C列：商品名１　D列：商品名２　E列：商店名　F列：画像　G列：１週目　
　H列：２週目　I列：３週目　J列：４週目　K列：５週目　の項目になっている
・別シートには、コード１、商品名１、商品名２の一覧表がある

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

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

回答の条件

1人5回まで
13歳以上

登録：2014/01/19 00:26:02
終了：2014/01/26 00:30:04

質問者から

にゃんころね2014/01/25 00:16:40

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

１．画像をセルにおさめる時、画像の高さに合わせて行の高さを調整したいです。

※幅は200ピクセルで一定ですが、高さはばらばらです。

２．画像とセルの隙間、上下左右に余白を2mm程度入れたいのです。

よろしくお願いします。

規約違反として通知

Mook 2014/01/21 07:56:20

それぞれのシート名と、別シートのコードと商品名の構成（列）はどうなっているのでしょう。
にゃんころね 2014/01/21 14:16:36

シート名は、「仕入れ商品表」と「商品一覧」になります。
また、別シートのコードは、頭が!＋８桁のランダムな半角英数字（計９桁です。
商品名の構成は、A列：コード１　B列：商品名１　C列：商品名２となります。
A列：!CE9767CA　B列：りんご　C列：紅玉　といった感じになります。

よろしくお願いします。

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

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

ともだちから選択
リクエスト送信済

回答リクエストを送信したユーザーはいません

Mook · Accepted Answer · 2014-01-22T21:45:19+09:00

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

商店＋ファイル名が一致するデータは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
    
    '//--------------------
    '// 一覧データの読込
    '//--------------------
    Dim 行 As 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週目", "3週目", "4週目", "5週目", "不明")
    
    集計シート.Columns("F").ColumnWidth = 画像サイズ横
    Dim サブフォルダ As Scripting.Folder
    Dim ファイル As Scripting.File
    Dim 週 As 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 To 行
                        If 集計シート.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
    
    '//--------------------
    '// 一覧データの読込
    '//--------------------
    Dim 行 As 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週目", "3週目", "4週目", "5週目", "不明")
    
    Dim サブフォルダ As Scripting.Folder
    Dim ファイル As Scripting.File
    Dim 週 As 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 To 行
                        If 集計シート.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

Mook · Accepted Answer · 2014-01-22T21:45:19+09:00

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

商店＋ファイル名が一致するデータは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
    
    '//--------------------
    '// 一覧データの読込
    '//--------------------
    Dim 行 As 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週目", "3週目", "4週目", "5週目", "不明")
    
    集計シート.Columns("F").ColumnWidth = 画像サイズ横
    Dim サブフォルダ As Scripting.Folder
    Dim ファイル As Scripting.File
    Dim 週 As 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 To 行
                        If 集計シート.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
    
    '//--------------------
    '// 一覧データの読込
    '//--------------------
    Dim 行 As 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週目", "3週目", "4週目", "5週目", "不明")
    
    Dim サブフォルダ As Scripting.Folder
    Dim ファイル As Scripting.File
    Dim 週 As 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 To 行
                        If 集計シート.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

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

ベストアンサー

Mook13143932014/01/22 21:45:19

その他の回答（0件）

Mook13143932014/01/22 21:45:19ここでベストアンサー

質問者から

コメント（2件)

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