Excel VBA批量插入图片偏移 如何精准定位至指定单元格

现有实现代码 #

以下是编写的用于在工作表中插入图片的VBA代码：

工作表变更触发事件代码：

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next

    If Target.Address = "$A$2" Then
        Call schedules
    End If
End Sub

核心图片插入逻辑代码：

Sub schedules()
    Worksheets("Picture").Activate
    
    Application.ScreenUpdating = False

    Dim myObj
    Dim Foto
    Set myObj = ActiveSheet.DrawingObjects

    For Each Foto In myObj
        If Left(Foto.Name, 7) = "Picture" Then
            Foto.Select
            Foto.Delete
        End If
    Next
    
    Dim CommodityName1 As String, CommodityName2 As String, T1 As String, T2 As String
    Dim i As Integer, j As Integer, k As Integer
        
    l = 0
    j = 0
    
    For i = 2 To 200
        myDir = "C:\Users\User\Desktop\ESTIMATING SHEETS\test\rebar shapes" & "\"
        CommodityName1 = Range("A" & i)
        T1 = ".png"

        On Error GoTo errormessage:
        ActiveSheet.Shapes.AddPicture Filename:=myDir & CommodityName1 & T1, _
          linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=230, Top:=j, Width:=140, Height:=80

errormessage:
        If Err.Number = 1004 Then
            Exit Sub
            MsgBox "File does not exist." & vbCrLf & "Check the name of the rebar!"
            Range("A" & i).Value = ""
            Range("C10").Value = ""
        End If

        Application.ScreenUpdating = True
        i = i + 11
        j = j + 190
        l = l + 1

        If l = 4 Then
            j = j - 20
            Application.ScreenUpdating = True
            l = 0
        End If
    Next i
End Sub

问题现象 #

第一次循环迭代后，插入的图片就会出现位置错位问题，异常效果参考：

此前尝试添加如下代码，每插入4张图片就调整Top偏移量j的数值修正偏移，但未生效：

If l = 4 Then
    j = j - 20
    Application.ScreenUpdating = True
    l = 0
End If

解决方案 #

不要手动计算Top、Left偏移值，直接绑定目标单元格的位置属性放置图片，从根源上避免手动计算偏移带来的错位问题，同时修正原有代码的逻辑bug：

• 原有错误处理逻辑顺序错误：Exit Sub写在MsgBox前面，会导致报错时提示框根本不弹出就直接退出过程
• 循环中手动修改循环变量i = i + 11的写法容易出现步长计算混乱，建议直接设置循环步长
• 手动累加j值计算偏移的方式容错率极低，直接取目标单元格的Top和Left属性作为图片坐标即可100%对齐单元格位置
• ScreenUpdating只需要在过程开始时关闭、全部逻辑执行完再打开即可，不需要在循环中反复开关，会影响执行效率还容易导致渲染错位

修正后的核心插入逻辑参考：

Sub schedules()
    Dim ws As Worksheet
    Dim Foto As Object
    Dim myDir As String, CommodityName1 As String, T1 As String
    Dim i As Long, l As Long, targetRow As Long
    
    ' 直接绑定工作表对象，不需要Activate激活工作表
    Set ws = ThisWorkbook.Worksheets("Picture")
    myDir = "C:\Users\User\Desktop\ESTIMATING SHEETS\test\rebar shapes\"
    T1 = ".png"
    
    Application.ScreenUpdating = False
    
    ' 清空原有旧图片
    For Each Foto In ws.DrawingObjects
        If Left(Foto.Name, 7) = "Picture" Then Foto.Delete
    Next
    
    l = 0
    targetRow = 2 ' 第一张图片对齐的起始行号
    ' 步长设为12，对应原逻辑每次i+11的取值规则
    For i = 2 To 200 Step 12
        CommodityName1 = ws.Range("A" & i).Value
        If CommodityName1 = "" Then GoTo errormessage
        
        ' 直接读取目标单元格的Top、Left属性定位，完全对齐单元格无错位
        ws.Shapes.AddPicture _
            Filename:=myDir & CommodityName1 & T1, _
            linktofile:=msoFalse, _
            savewithdocument:=msoTrue, _
            Left:=ws.Range("B" & targetRow).Left, ' 可替换为实际需要放置图片的目标列
            Top:=ws.Range("B" & targetRow).Top, _
            Width:=140, _
            Height:=80
        
        ' 下一张图的行偏移：每张图占80高度+10磅间距，可根据实际需求调整
        targetRow = targetRow + 5
        l = l + 1
        
        ' 每4张图调整一次行间距，直接控制targetRow即可，不需要手动计算像素偏移
        If l = 4 Then
            targetRow = targetRow + 1
            l = 0
        End If
    Next i

    Application.ScreenUpdating = True
    Exit Sub

errormessage:
    Application.ScreenUpdating = True
    MsgBox "文件不存在，请检查钢筋名称是否正确！", vbExclamation
    ws.Range("A" & i).Value = ""
    ws.Range("C10").Value = ""
End Sub

提示：代码中ws.Range("B" & targetRow)可替换为实际要对齐的目标单元格，只要取单元格的Top和Left属性赋值给图片，图片就会完全贴合单元格位置，不会出现居中偏移、位置错位的问题。

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