Excel插入图片VBA脚本异常：前20行正常后续错位/不插入问题排查

我有一份包含各类产品零件号的Excel表格，零件号位于Q列，现有VBA脚本可读取零件号并将对应图片插入P列。该脚本前20行运行正常，但后续出现图片不插入或插入至上方行的异常，请求排查代码问题。

原VBA代码 #

Application.ScreenUpdating = False
Dim picname As String
    Dim shp As Shape
    Dim pasteAt As Integer
    Dim lThisRow As Long

    lThisRow = 11 'This is the start row

    Do While (Cells(lThisRow, 2) <> "")


        pasteAt = lThisRow
        Cells(pasteAt, 16).Select 'This is where picture will be inserted (column)


        picname = Cells(lThisRow, 17) 'This is the picture name

        present = Dir("z:\1A - MICO IMAGE FILE - OFFICIAL\" & picname & ".jpg")

        If present <> "" Then

            Cells(pasteAt, 16).Select

            Call ActiveSheet.Shapes.AddPicture("z:\1A - MICO IMAGE FILE - OFFICIAL\" & picname & ".jpg", _
            msoCTrue, msoCTrue, Left:=Cells(pasteAt, 16).Left, Top:=Cells(pasteAt, 16).Top, Width:=100, Height:=100).Select


        Else
            Cells(pasteAt, 16) = "Image Unavailable"
        End If

        lThisRow = lThisRow + 1
    Loop

    Range("O1").Select
    Application.ScreenUpdating = True
    
  For Each shp In ActiveSheet.Shapes
        If shp.TopLeftCell.Column = 16 Then
            With shp
                .Top = Range(shp.TopLeftCell.Address).Top + ((Range(shp.TopLeftCell.Address).Height - shp.Height) / 2)
                .Left = Range(shp.TopLeftCell.Address).Left + ((Range(shp.TopLeftCell.Address).Width - shp.Width) / 2)
            End With
        End If
    Next shp
    Exit Sub
    

ErrNoPhoto:
    MsgBox "Some of the images are not available" 'Shows message box if picture not found
    Exit Sub
    Range("O7").Select
End Sub

问题排查与修正 #

核心问题点 #

1. 变量类型溢出：pasteAt被定义为Integer，但Excel行号上限远超Integer的32767，后续行号超出范围后变量值异常，导致图片插入位置错乱。
2. 依赖Select操作：频繁用Select定位单元格，行号增多时容易出现焦点偏差，引发定位错误。
3. 错误处理失效：代码里的ErrNoPhoto标签没有被触发逻辑，缺少On Error GoTo ErrNoPhoto语句，图片加载出错时无法捕获异常。
4. 居中逻辑冗余：插入图片后再遍历所有形状调整位置，效率低且容易引发位置计算误差。

修正后的代码 #

Sub InsertPartImages()
    Application.ScreenUpdating = False
    Dim picName As String
    Dim targetCell As Range
    Dim lThisRow As Long
    Dim imgPath As String
    
    imgPath = "z:\1A - MICO IMAGE FILE - OFFICIAL\"
    lThisRow = 11 '起始行
    
    '开启错误捕获
    On Error GoTo ErrNoPhoto
    
    Do While Cells(lThisRow, 2) <> ""
        Set targetCell = Cells(lThisRow, 16) 'P列目标单元格
        picName = Cells(lThisRow, 17).Value 'Q列零件号
        
        '检查图片是否存在
        If Dir(imgPath & picName & ".jpg") <> "" Then
            '直接插入图片并设置居中，取消Select操作
            With ActiveSheet.Shapes.AddPicture( _
                Filename:=imgPath & picName & ".jpg", _
                LinkToFile:=msoFalse, _
                SaveWithDocument:=msoCTrue, _
                Left:=targetCell.Left + (targetCell.Width - 100) / 2, _
                Top:=targetCell.Top + (targetCell.Height - 100) / 2, _
                Width:=100, Height:=100)
                '设置图片随单元格移动调整
                .Placement = xlMoveAndSize
            End With
        Else
            targetCell.Value = "Image Unavailable"
        End If
        
        lThisRow = lThisRow + 1
    Loop
    
Cleanup:
    Application.ScreenUpdating = True
    Exit Sub
    
ErrNoPhoto:
    MsgBox "部分图片无法加载，请检查路径或零件号"
    Resume Cleanup
End Sub

修正说明 #

• 移除pasteAt变量，改用targetCell直接引用单元格，彻底取消Select操作，避免定位偏差。
• 所有行号相关变量统一用Long类型，杜绝溢出问题。
• 插入图片时直接计算居中位置，无需后续遍历调整，提升运行效率。
• 添加On Error GoTo ErrNoPhoto启用错误捕获，异常时能触发提示并正常收尾。
• 设置图片Placement属性，保证图片和单元格同步移动、调整尺寸。

内容的提问来源于stack exchange，提问作者Mike Warr