office Excel 中用 VBA 实现随机插入图片到指定单元格

最近更新于 2026-02-25 16:39

2026/2/25
代码由 Google Gemini 生成，功能如下：

• 指定图片来源的目录；
• 指定图片插入的单元格；
• 随机抽取图片插入；
• 插入的图片填充满单元格（如果存在合并单元格，则填充满合并后的单元格），图片缩放保持比例；
• 对应表中任意单元格发生修改时触发随机插入图片；
• 插入新图片后删除在指定单元格（及合并单元格）范围内的其它所有图片。
  

该功能是一个同事提出的需求，用于随机抽取图片填充到报告中，避免每次报告都是同一张图片。

代码如下：

Private Sub Worksheet_Change(ByVal Target As Range)
    ' --- 配置区域 ---
    Dim targetCellAddress As String
    Dim imageFolderPath As String

    ' 1. 指定图片填充的单元格（支持合并单元格）
    targetCellAddress = "F5"

    ' 2. 指定图片文件夹路径
    imageFolderPath = "C:\Users\IYATTyx\Pictures\Screenshots"
    ' ----------------

    Dim rngTarget As Range
    Dim fso As Object
    Dim file As Object
    Dim imgFiles As New Collection
    Dim randomIdx As Integer
    Dim fullPath As String
    Dim shp As Shape
    Dim pic As Shape
    Dim ratioCell As Double, ratioPic As Double
    Dim ext As String

    ' 确保路径以反斜杠结尾
    If Right(imageFolderPath, 1) <> "\" Then imageFolderPath = imageFolderPath & "\"

    On Error GoTo ErrorHandler
    Application.EnableEvents = False ' 禁用事件，防止递归触发

    Set rngTarget = Me.Range(targetCellAddress).MergeArea

    ' 1. 删除目标区域及其重叠范围内的旧图片
    For Each shp In Me.Shapes
        If Not Intersect(shp.TopLeftCell, rngTarget) Is Nothing Then
            shp.Delete
        End If
    Next shp

    ' 2. 初始化文件系统对象
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(imageFolderPath) Then
        MsgBox "文件夹路径不存在，请检查：" & vbCrLf & imageFolderPath, vbExclamation
        GoTo CleanUp
    End If

    ' 3. 遍历并记录所有常用格式图片
    For Each file In fso.GetFolder(imageFolderPath).Files
        ext = LCase(fso.GetExtensionName(file.Name))
        Select Case ext
            ' 涵盖绝大多数常用图片格式
            Case "jpg", "jpeg", "png", "bmp", "gif", "webp", "jfif", "tif", "tiff", "ico"
                imgFiles.Add file.Path
        End Select
    Next file

    If imgFiles.Count = 0 Then
        ' 如果没找到图片，直接退出不报错
        GoTo CleanUp
    End If

    ' 4. 随机抽取
    Randomize
    randomIdx = Int((imgFiles.Count * Rnd) + 1)
    fullPath = imgFiles(randomIdx)

    ' 5. 插入图片
    ' 使用 Width:=-1, Height:=-1 以保持原始比例导入
    Set pic = Me.Shapes.AddPicture(Filename:=fullPath, _
                                  LinkToFile:=msoFalse, _
                                  SaveWithDocument:=msoTrue, _
                                  Left:=rngTarget.Left, _
                                  Top:=rngTarget.Top, _
                                  Width:=-1, Height:=-1)

    pic.LockAspectRatio = msoTrue ' 锁定纵横比

    ' 6. 计算缩放比例 (保证图片完全位于单元格内)
    ratioCell = rngTarget.Width / rngTarget.Height
    ratioPic = pic.Width / pic.Height

    If ratioPic > ratioCell Then
        ' 图片太宽，以单元格宽度为基准缩放
        pic.Width = rngTarget.Width
    Else
        ' 图片太高，以单元格高度为基准缩放
        pic.Height = rngTarget.Height
    End If

    ' 7. 居中放置
    pic.Left = rngTarget.Left + (rngTarget.Width - pic.Width) / 2
    pic.Top = rngTarget.Top + (rngTarget.Height - pic.Height) / 2

CleanUp:
    Application.EnableEvents = True
    Exit Sub

ErrorHandler:
    MsgBox "程序运行出错: " & Err.Description, vbCritical
    Resume CleanUp
End Sub

在 Excel 中按 Alt+F11 打开宏编辑器，在对应的工作簿的表格插入上面代码，我这里就是工作簿4的Sheet1表

保存 Excel 文件时选 .xlsm 格式，可以保存宏