如何将图片加载到excel单元格中并将其保存在文档中

准备土壤：

Sub Main_Pictures()
    Dim rCell As Range              ' ячейка для вставки'
    Dim FolderPictures As String    ' путь к папке с рисунками'
    
    FolderPictures = ThisWorkbook.Path & "\pictures"
    If Dir(FolderPictures, vbDirectory) = "" Then MsgBox "Нет папки с рисунками", 64, "ОШИБКА": Exit Sub
    Set rCell = ActiveCell
    
    If MsgBox("Вставить рисунок?", 64 + vbYesNo, "") = vbNo Then Exit Sub
    
    Application.ScreenUpdating = False
    Call InsertPictures(rCell, FolderPictures)
    Application.ScreenUpdating = True
End Sub

文件夹内容示例：

在文件夹中搜索所需文件的功能：

Function fPathPicture(FolderPictures As String, NamePicture As String) As String
    Dim FileName As String, s As String
    
    FileName = Dir(FolderPictures & "\*")

    Do While FileName <> ""
        s = Left$(FileName, InStrRev(FileName, ".") - 1)
        
        If s = NamePicture Then
            fPathPicture = FolderPictures & "\" & FileName
            Exit Function
        End If

        FileName = Dir
    Loop
End Function

宏处理前的单元格：

我们用在单元格中显示名称的图片来装饰单元格：

Sub InsertPictures(rCell As Range, FolderPictures As String)
    Dim oPic As Shape
    Dim PathPicture As String

    PathPicture = fPathPicture(FolderPictures, rCell.Value)
        
    If PathPicture <> "" Then
        Set oPic = rCell.Worksheet.Shapes.AddPicture(PathPicture, 0, 1, -1, -1, -1, -1)
        
        With oPic
            .Width = rCell.Width - 4
            .Height = rCell.Height - 4
                
            .Left = rCell.Left + 2
            .Top = rCell.Top + 2
        End With
    Else
        rCell.Value = rCell.Value & Chr$(10) & "нет картинки"
    End If
    
    Set oPic = Nothing
End Sub

插入（并尝试插入）图纸的结果：

如果添加单元格绕过循环，则可以批量插入图片（例如，插入到新创建的百万订单价目表中:)）