做法是這樣
新增一個form跟一個module
在模組中呼叫表單

執行完後就會把圖片插入到指定的欄位

Public Sub ImportPictures()
    Load frmMedia
    frmMedia.Show
End Sub

表單組成跟選項是這樣做

中間的相關參數看你自己設定

表單程式

'關閉按鈕
Private Sub ImportClose_Click()
    Me.Hide
    Unload Me
End Sub

'執行按鈕
Private Sub ImportStart_Click()
    On Error Resume Next
    Dim sFilename As String, sSize As String
    Dim sArticleColumn As String, sPictureColumn As String
    Dim iRowHeight As Integer, iColumnWidth As Integer, iEmpty As Integer, iShapes As Integer, iAnz As Integer
    Dim basePath As String, picFormat As String
    
    
    basePath = "貨號圖片的路徑"
    picFormat = ".png" '圖片副檔名
    
    iShapes = ActiveSheet.Shapes.Count
    
    If ActiveSheet.ProtectDrawingObjects = True Or ActiveSheet.ProtectContents = True Or ActiveSheet.ProtectScenarios = True Then
        MsgBox "資料表保護中請移除或確定權限!", vbInformation, "圖片插入工具"
        Exit Sub
    End If
    If optSizeSmall.Value = True Then
        sSize = "s"
        iRowHeight = 3 * 29.5               '100 Pixel ^ 3 cm
        iColumnWidth = -0.71 + 5.1425 * 3   '100 Pixel ^ 3 cm
    ElseIf optSizeMedium.Value = True Then
        sSize = "m"
        iRowHeight = 6 * 29.5               '240 Pixel ^ 6 cm
        iColumnWidth = -0.71 + 5.1425 * 6   '240 Pixel ^ 6 cm
    ElseIf optSizeLarge.Value = True Then
        sSize = "l"
        iRowHeight = 10 * 29.5              '360 Pixel ^ 10 cm
        iColumnWidth = -0.71 + 5.1425 * 10  '360 Pixel ^ 10 cm
    ElseIf optSizeOffice.Value = True Then
        sSize = "o"
        iRowHeight = 0                      'various sizes
        iColumnWidth = 0                    'various sizes
    ElseIf optSizeLineDrawing.Value = True Then
        sSize = "d"
        iRowHeight = 0                      'various sizes
        iColumnWidth = 0                    'various sizes
    End If

        '資料檢查
        '這段是確認使用者輸入的欄位，有部分欄位要配合公司內部其他部門使用，會限制範圍 
        '這段是確認要插入圖片的欄位
   
    sArticleColumn = UCase(Trim(txtArticleNrColumn.Text))
    sPictureColumn = UCase(Trim(txtPictureColumn.Text))
    
    If optSizeFitPicture.Value = True Then
        Range(sPictureColumn & ":" & sPictureColumn).Columns.ColumnWidth = iColumnWidth
    End If
    For i = 1 To 10000 '限制最多只能插入多少
        If Trim(Range(sArticleColumn & CStr(i)).Text) = "" Or IsEmpty(Trim(Range(sArticleColumn & CStr(i)).Text)) Then
            iEmpty = iEmpty + 1
            If iEmpty > 5 Then GoTo FINISH
        Else
            iEmpty = 0
            sBildname = Trim(Replace(Trim(CStr(Range(sArticleColumn & CStr(i)))), " ", ""))
                
                '這段你自己處理，通常是做基本的貨號格式確認，避免抓不到檔案
            
                sFilename = basePath & sBildname & picFormat
                If optSizeFitPicture.Value = True Then ActiveSheet.Rows(i).RowHeight = iRowHeight
                InsertPicture sFilename, sBildname, Range(sPictureColumn & CStr(i)), False, True
            
        End If
    Next
FINISH:
    Cells(1, 1).Select
    iAnz = ActiveSheet.Shapes.Count - iShapes
    MsgBox CStr(iAnz) & " 圖片插入完成!", vbInformation, "圖片插入工具"
    frmMedia.Hide
    Unload frmMedia
    On Error GoTo 0
End Sub

'圖片插入程式
Private Sub InsertPicture(PictureFileName As String, ByVal Bildname As String, TargetCell As Range, _
                          CenterH As Boolean, CenterV As Boolean)
Dim p As Object, t As Double, l As Double, w As Double, h As Double
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    
    Set p = ActiveSheet.Pictures.Insert(PictureFileName)
    
    p.Name = Bildname & "jpeg"
    With TargetCell
        .Value = sBildname
        p.Height = TargetCell.Height
        p.Width = TargetCell.Width
        t = .Top
        l = .Left
        If CenterH Then
            w = .Offset(0, 1).Left - .Left
            l = l + w / 2 - p.Width / 2
            If l < 1 Then l = 1
        End If
        If CenterV Then
            h = .Offset(1, 0).Top - .Top
            t = t + h / 2 - p.Height / 2
            If t < 1 Then t = 1
        End If
    End With
    With p
        .Top = t
        .Left = l
    End With
    
   Set p = Nothing
End Sub