vba - VBA - Excel - 一致するファイル名で写真を取得してセルに配置する方法

Question

列 A に製品コードのリストがある Excel シートがあります。また、各製品の写真が入ったフォルダがあり、写真のファイル名は製品コードです。各製品の写真をそれぞれのコードの横の列 B に配置したいと思います。可能であれば、セルに収まるように写真を再フォーマットしたいと思います。

どこから始めればいいのか本当にわかりません。助けていただければ幸いです。ありがとう

Answer 1

開始するコードは次のとおりです。あなたの側でそれをテストしてください。

 Sub AddPictures()
 Dim myPic As Picture
 Dim wkSheet As Worksheet
 Dim myRng As Range
 Dim myCell As Range
 Dim rowCount As Long
 Dim rowCount2 As Long

     Set wkSheet = Sheets(2) ' -- Change to your sheet

    '-- The usual way of finding used row count for specific column
    rowCount2 = wkSheet.Cells(wkSheet.Rows.Count, "C").End(xlUp).Row

    If rowCount2 <> 0 Then
        Set myRng = wkSheet.Range("C2", wkSheet.Cells(wkSheet.Rows.Count, "C").End(xlUp))

        For Each myCell In myRng.Cells
               If Trim(myCell.Value) = "" Then
                    MsgBox "No file path"
               ElseIf Dir(CStr(myCell.Value)) = "" Then
                    MsgBox myCell.Value & " Doesn't exist!"
               Else
                    myCell.Offset(0, 1).Parent.Pictures.Insert (myCell.Value)
                    Set myPic = myCell.Parent.Pictures.Insert(myCell.Value)

                    With myCell.Offset(0, 1)  '1 columns to the right of C ( is D)
                        '-- resize image here to fit into the size of your cell
                        myPic.Top = .Top
                        myPic.Width = .Width
                        myPic.Height = .Height
                        myPic.Left = .Left
                        myPic.Placement = xlMoveAndSize
                    End With
               End If
        Next myCell

    Else
        MsgBox "There is no file paths in your column"
    End If
End Sub

出力：

---

PS：値に応じて範囲、ファイルパスを設定します。使用されている REAL の列と行をシート全体で検索する必要がある場合は、お知らせください。そのための機能を共有できます。現時点では、特定のファイル パス列で使用されている行を見つけるだけでよいため、上記の典型的な使用されている行数の行で十分です。