哪位大神帮我调一下偏移，怎么调都到不了指定单元格

light456

重新找到了一个代码修改，但是偏移总是调不好，哪个大神能帮我调一下。谢谢！！！


Function 插入2(rg As Range) '图片存在文档
    'Application.Volatile
     ActiveSheet.Unprotect
    Dim MyFile As String, MyPath As String, T, L, W, H
    MyPath = Sheet1.[ay1] & "\"
    MyFile = Trim(rg.Value) & ".jpg"
    If Dir(MyPath & MyFile) = "" Then Exit Function
    T = rg.Offset(1, 2).Top + 1  '对应编码的列的偏移量
    L = rg.Offset(1, 2).Left     '对应编码的列的偏移量
    W = rg.Offset(1, 2).Width  '对应编码的列的偏移量
    H = rg.Offset(1, 2).Height - 1 '对应编码的列的偏移量
    ActiveSheet.Shapes.AddPicture MyPath & MyFile, msoFalse, msoTrue, L, T, W, H
    End Function
Sub 批量插入图片()
Application.ScreenUpdating = False
  ActiveSheet.Unprotect
   Dim n, r, i, j, k, s
    For i = 6 To Sheet1.[a20].End(xlUp).Row
    For r = 1 To 1
    插入2 Sheet1.Cells(i - 1, r) '编码所在列数。
Next
         Next
Application.ScreenUpdating = True

For j = 6 To Sheet1.[e20].End(xlUp).Row
      For r = 5 To 5
    插入2 Sheet1.Cells(j, r)   '编码所在列数。
Next
         Next
Application.ScreenUpdating = True

    For k = 6 To Sheet1.[i20].End(xlUp).Row
    For r = 9 To 9
    插入2 Sheet1.Cells(k, r)   '编码所在列数。
Next
         Next
Application.ScreenUpdating = True


End Sub

Sub GetSourcePath()

On Error Resume Next
       Application.ScreenUpdating = False '禁止屏幕刷新
        Dim MyPath$, MyFile$, k% '定义文件夹和文件
        With Application.FileDialog(msoFileDialogFolderPicker) '进入一个文件夹选择对话框
            If .Show Then                                      '如果进入文件夹选择对话框有选中的文件则
             MyPath = .SelectedItems(1)                        'Mypath就等于选中的文件路径
            End If
        End With
           If MyPath <> "" Then Sheet1.Range("AY1").Value = MyPath '如果选中文件不等于空就让sheet.[ay1]等于文件夹的路径
           ys = MsgBox(" 请确认是否插入图片 !", vbOKCancel, "确认窗口") '调出msgbox 对话框，询问是否需要插入图片，有是和取消两个选项
           If ys = 1 Then
        Call 批量插入图片
        End If
        Application.ScreenUpdating = True

End Sub

Sub delpic() '批量删除照片
    Dim p As Shape
        For Each p In ActiveSheet.Shapes
            If Not Application.Intersect(p.TopLeftCell, Range("c6:c20")) Is Nothing Then
                p.Delete
            End If
        Next
         For Each p In ActiveSheet.Shapes
            If Not Application.Intersect(p.TopLeftCell, Range("g6:g20")) Is Nothing Then
                p.Delete
            End If
        Next
         For Each p In ActiveSheet.Shapes
            If Not Application.Intersect(p.TopLeftCell, Range("k6:k20")) Is Nothing Then
                p.Delete
            End If
        Next





    End Sub

liulang0808

Function 插入2(rg As Range) '图片存在文档
    'Application.Volatile
     ActiveSheet.Unprotect
    Dim MyFile As String, MyPath As String, T, L, W, H
    MyPath = Sheet1.[ay1] & "\"
    MyFile = Trim(rg.Value) & ".jpg"
    If Dir(MyPath & MyFile) = "" Then Exit Function
    Set Rng = rg.Offset(0, 2).Offset(1)
    Rng.Select
    Set Rng = Selection
    T = Rng.Top + 1 '对应编码的列的偏移量
    L = Rng.Left     '对应编码的列的偏移量
    W = Rng.Width  '对应编码的列的偏移量
    H = Rng.Height - 1 '对应编码的列的偏移量
    ActiveSheet.Shapes.AddPicture MyPath & MyFile, msoFalse, msoTrue, L, T, W, H
    End Function
Sub 批量插入图片()
Application.ScreenUpdating = False
  ActiveSheet.Unprotect
   Dim n, r, i, j, k, s
    For i = 6 To Sheet1.[a20].End(xlUp).Row + 1
        For r = 1 To 9 Step 4
            If Len(Sheet1.Cells(i - 1, r)) <> "" Then
            插入2 Sheet1.Cells(i - 1, r) '编码所在列数。
            End If
        Next
    Next
' Application.ScreenUpdating = True
'
' For j = 6 To Sheet1.[e20].End(xlUp).Row + 1
'      For r = 5 To 5
'    插入2 Sheet1.Cells(j, r)   '编码所在列数。
'Next
'         Next
' Application.ScreenUpdating = True
'
'    For k = 6 To Sheet1.[i20].End(xlUp).Row + 1
'    For r = 9 To 9
'    插入2 Sheet1.Cells(k, r)   '编码所在列数。
'Next
'         Next
Application.ScreenUpdating = True

  
End Sub

Sub GetSourcePath()

On Error Resume Next
       Application.ScreenUpdating = False '禁止屏幕刷新
        Dim MyPath$, MyFile$, k% '定义文件夹和文件
        With Application.FileDialog(msoFileDialogFolderPicker) '进入一个文件夹选择对话框
            If .Show Then                                      '如果进入文件夹选择对话框有选中的文件则
             MyPath = .SelectedItems(1)                        'Mypath就等于选中的文件路径
            End If
        End With
           If MyPath <> "" Then Sheet1.Range("AY1").Value = MyPath '如果选中文件不等于空就让sheet.[ay1]等于文件夹的路径
           ys = MsgBox(" 请确认是否插入图片 !", vbOKCancel, "确认窗口") '调出msgbox 对话框，询问是否需要插入图片，有是和取消两个选项
           If ys = 1 Then
        Call 批量插入图片
        End If
        Application.ScreenUpdating = True
   
End Sub

Sub delpic() '批量删除照片
    Dim p As Shape
        For Each p In ActiveSheet.Shapes
            If Not Application.Intersect(p.TopLeftCell, Range("c6:c20")) Is Nothing Then
                p.Delete
            End If
        Next
         For Each p In ActiveSheet.Shapes
            If Not Application.Intersect(p.TopLeftCell, Range("g6:g20")) Is Nothing Then
                p.Delete
            End If
        Next
         For Each p In ActiveSheet.Shapes
            If Not Application.Intersect(p.TopLeftCell, Range("k6:k20")) Is Nothing Then
                p.Delete
            End If
        Next
        
        
        
        
        
    End Sub

liulang0808

1 (7).zip (336.95 KB, 下载次数: 18)

2023-7-7 08:01 上传

点击文件名下载附件

代码格式有些乱，表格布局也不是太规范，根据附件内容猜着整的，供参考

鄂龙蒙

作业前后照片对比.rar (23.47 KB, 下载次数: 2)

2023-7-7 08:45 上传

点击文件名下载附件

light456

liulang0808 发表于 2023-7-7 08:01
代码格式有些乱，表格布局也不是太规范，根据附件内容猜着整的，供参考

感谢，完美解决！！！！

light456

liulang0808 发表于 2023-7-7 08:01
代码格式有些乱，表格布局也不是太规范，根据附件内容猜着整的，供参考

大神，我有一个问题，这个代码只能用于本工作簿，用其他工作簿调用这个vba能运行但是显示不了图片，这个为什么。

liulang0808

light456 发表于 2023-7-20 10:55
大神，我有一个问题，这个代码只能用于本工作簿，用其他工作簿调用这个vba能运行但是显示不了图片，这个 ...

用于其他工作簿是怎么用的？
建议在处理图片部分设置断点，对应分步执行确认下原因吧