简单快速用法如下：

准备工作： 确保图片文件名（如 型号123.jpg）和 Excel 里的名字（型号123）一致。

贴代码：
在 Excel 中按 Alt + F11，点击菜单栏 插入 -> 模块，把代码粘贴进去。

运行：
在代码窗口内直接按 F5 键。

按弹窗提示输入 4 次：

① 选择 图片所在的文件夹。
② 输入 型号名字在哪一列（例如输入 A）。
③ 输入 图片要放在哪一列（例如输入 B）。
④ 输入 大小数值（建议输入 80）。
结果： 程序会自动把 B 列变成正方形格子，并把图片完美塞进去。

Sub BatchInsertImages_Square_Fixed()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long
    Dim picName As String, picPath As String, folderPath As String
    Dim shp As Shape ' 改用 Shape 对象
    Dim targetCell As Range
    Dim fileExtensions As Variant, ext As Variant
    Dim fileFound As Boolean
    
    ' 用户输入变量
    Dim nameColStr As String
    Dim imgColStr As String
    Dim sideLength As Double ' 边长（既是高度也是宽度）
    Dim fd As FileDialog
    
    ' ================= 1. 获取用户参数 =================
    
    ' 1.1 选择图片文件夹
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = "第一步：请选择包含图片的文件夹"
        If .Show = -1 Then
            folderPath = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With
    
    ' 1.2 输入文件名所在列
    nameColStr = InputBox("第二步：请输入【文件名】所在的列号（例如 A）：", "参数设置", "A")
    If nameColStr = "" Then Exit Sub
    
    ' 1.3 输入图片插入列
    imgColStr = InputBox("第三步：请输入【图片】要插入的列号（例如 B）：", "参数设置", "B")
    If imgColStr = "" Then Exit Sub
    
    ' 1.4 输入尺寸（边长）
    sideLength = Application.InputBox("第四步：请输入【图片边长/行高】" & vbCrLf & _
                                      "单元格将变为正方形以适应此大小。" & vbCrLf & _
                                      "(建议输入 60 - 80)", "参数设置", 80, Type:=1)
    If sideLength <= 0 Then Exit Sub

    ' ================= 2. 调整单元格为正方形 =================
    
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, nameColStr).End(xlUp).Row
    fileExtensions = Array(".jpg", ".jpeg", ".png", ".bmp", ".gif")
    
    Application.ScreenUpdating = False
    
    ' 2.1 设置行高
    ws.Range(ws.Cells(2, nameColStr), ws.Cells(lastRow, nameColStr)).EntireRow.RowHeight = sideLength
    
    ' 2.2 设置列宽 (让列宽看起来跟行高一样宽)
    ' Excel的列宽单位很特殊，大约 1个列宽单位 ≈ 6个磅(Points)
    ' 这个公式可以让单元格看起来接近正方形
    ws.Columns(imgColStr).ColumnWidth = sideLength / 6
    
    ' ================= 3. 循环插入图片 =================
    
    For i = 2 To lastRow
        picName = Trim(ws.Cells(i, nameColStr).Value)
        Set targetCell = ws.Cells(i, imgColStr)
        
        If picName <> "" Then
            ' 清理旧图片 (Shape模式)
            Dim s As Shape
            For Each s In ws.Shapes
                If s.TopLeftCell.Address = targetCell.Address Then s.Delete
            Next s
            
            ' 寻找文件
            fileFound = False
            For Each ext In fileExtensions
                picPath = folderPath & picName & ext
                If Dir(picPath) <> "" Then
                    fileFound = True
                    Exit For
                End If
            Next ext
            
            If fileFound Then
                ' 使用 AddPicture 方法，这是防止变形的关键
                ' 参数说明: Filename, LinkToFile, SaveWithDocument, Left, Top, Width, Height
                ' 我们先插入，长宽设为 -1 (代表原始尺寸)，然后再强制调整
                Set shp = ws.Shapes.AddPicture(picPath, msoFalse, msoTrue, _
                                               targetCell.Left, targetCell.Top, -1, -1)
                
                With shp
                    ' 1. 锁定纵横比 (防止意外拉伸)
                    .LockAspectRatio = msoTrue
                    
                    ' 2. 强制设置高度和宽度
                    ' 既然是方形图，我们把高度和宽度设为一样
                    ' 减去 4 是为了留出一点点边距，不压线
                    .Height = sideLength - 4
                    
                    ' 再次检查宽度，如果图片原图有微小误差，这里强制修正宽度，确保它是正方形
                    ' 如果你希望严格保持原图比例（即使原图不是正方形），请删除下面这一行
                    If .Width > (sideLength - 4) Then .Width = sideLength - 4
                    
                    ' 3. 居中定位
                    .Top = targetCell.Top + (targetCell.Height - .Height) / 2
                    .Left = targetCell.Left + (targetCell.Width - .Width) / 2
                    
                    ' 4. 设置属性：随单元格移动
                    .Placement = xlMoveAndSize
                End With
            Else
                targetCell.Value = "无图"
            End If
        End If
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "处理完成！单元格已调整为方形。", vbInformation
End Sub

自动压缩图片

Sub BatchInsertImages_Square_Fixed_WithCompression()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long
    Dim picName As String, picPath As String, folderPath As String
    Dim shp As Shape
    Dim targetCell As Range
    Dim fileExtensions As Variant, ext As Variant
    Dim fileFound As Boolean
    
    ' 用户输入变量
    Dim nameColStr As String
    Dim imgColStr As String
    Dim sideLength As Double
    Dim fd As FileDialog
    
    ' WIA 图像处理对象声明
    Dim ImgFile As Object
    Dim ImgProcess As Object
    Dim tempImgPath As String
    Dim insertPath As String
    Dim maxResolution As Integer
    
    ' ================= 1. 获取用户参数 =================
    
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = "第一步：请选择包含图片的文件夹"
        If .Show = -1 Then
            folderPath = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With
    
    nameColStr = InputBox("第二步：请输入【文件名】所在的列号（例如 A）：", "参数设置", "A")
    If nameColStr = "" Then Exit Sub
    
    imgColStr = InputBox("第三步：请输入【图片】要插入的列号（例如 B）：", "参数设置", "B")
    If imgColStr = "" Then Exit Sub
    
    sideLength = Application.InputBox("第四步：请输入【图片边长/行高】" & vbCrLf & _
                                      "单元格将变为正方形以适应此大小。" & vbCrLf & _
                                      "(建议输入 60 - 80)", "参数设置", 80, Type:=1)
    If sideLength <= 0 Then Exit Sub

    ' ================= 2. 调整单元格为正方形 =================
    
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, nameColStr).End(xlUp).Row
    fileExtensions = Array(".jpg", ".jpeg", ".png", ".bmp", ".gif")
    
    ' 设置图片最大像素尺寸。300像素足以在80边长的单元格中保持极度清晰，同时极大降低文件体积
    maxResolution = 300 
    
    Application.ScreenUpdating = False
    
    ws.Range(ws.Cells(2, nameColStr), ws.Cells(lastRow, nameColStr)).EntireRow.RowHeight = sideLength
    ws.Columns(imgColStr).ColumnWidth = sideLength / 6
    
    ' 创建 WIA 对象，用于压缩图片
    On Error Resume Next
    Set ImgFile = CreateObject("WIA.ImageFile")
    Set ImgProcess = CreateObject("WIA.ImageProcess")
    On Error GoTo 0
    
    ' ================= 3. 循环插入图片 =================
    
    For i = 2 To lastRow
        picName = Trim(ws.Cells(i, nameColStr).Value)
        Set targetCell = ws.Cells(i, imgColStr)
        
        If picName <> "" Then
            ' 清理旧图片
            Dim s As Shape
            For Each s In ws.Shapes
                If s.TopLeftCell.Address = targetCell.Address Then s.Delete
            Next s
            
            ' 寻找文件
            fileFound = False
            For Each ext In fileExtensions
                picPath = folderPath & picName & ext
                If Dir(picPath) <> "" Then
                    fileFound = True
                    Exit For
                End If
            Next ext
            
            If fileFound Then
                insertPath = picPath ' 默认使用原图路径
                
                ' ================= 核心：图片压缩逻辑 =================
                If Not ImgFile Is Nothing And Not ImgProcess Is Nothing Then
                    On Error Resume Next
                    ImgFile.LoadFile picPath
                    
                    ' 只有当原图尺寸大于设定的最大分辨率时才压缩
                    If ImgFile.Width > maxResolution Or ImgFile.Height > maxResolution Then
                        ImgProcess.Filters.Add ImgProcess.FilterInfos("Scale").FilterID
                        ImgProcess.Filters(1).Properties("MaximumWidth") = maxResolution
                        ImgProcess.Filters(1).Properties("MaximumHeight") = maxResolution
                        ImgProcess.Filters(1).Properties("PreserveAspectRatio") = True
                        
                        Set ImgFile = ImgProcess.Apply(ImgFile)
                        
                        ' 生成临时文件路径 (保持原扩展名)
                        tempImgPath = Environ("TEMP") & "\temp_excel_img" & ext
                        If Dir(tempImgPath) <> "" Then Kill tempImgPath
                        
                        ImgFile.SaveFile tempImgPath
                        
                        ' 如果成功保存了临时文件，则将插入路径更改为临时文件
                        If Err.Number = 0 Then
                            insertPath = tempImgPath
                        End If
                    End If
                    ' 清理 Filter，为下一张图做准备
                    Do While ImgProcess.Filters.Count > 0
                        ImgProcess.Filters.Remove 1
                    Loop
                    On Error GoTo 0
                End If
                ' =======================================================
                
                ' 插入图片 (使用压缩后的 insertPath)
                Set shp = ws.Shapes.AddPicture(insertPath, msoFalse, msoTrue, _
                                               targetCell.Left, targetCell.Top, -1, -1)
                
                With shp
                    .LockAspectRatio = msoTrue
                    .Height = sideLength - 4
                    If .Width > (sideLength - 4) Then .Width = sideLength - 4
                    .Top = targetCell.Top + (targetCell.Height - .Height) / 2
                    .Left = targetCell.Left + (targetCell.Width - .Width) / 2
                    .Placement = xlMoveAndSize
                End With
                
                ' 插入完成后，如果使用了临时文件，则将其删除
                If insertPath = tempImgPath Then
                    If Dir(tempImgPath) <> "" Then Kill tempImgPath
                End If
                
            Else
                targetCell.Value = "无图"
            End If
        End If
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "处理完成！图片已压缩并插入。", vbInformation
End Sub