请老师写个代码，根据图片名称插入相对于的单元格

caiqizhong21

请老师、大神们，帮忙根据图片名称把图片放到B列中，图片大概100张。有时候，6图片没有，那么B列6的位置就空着后面以此类推！

醉眼看尘世

Sub 批量插图()
    Dim mSP As Object, sH As Worksheet, mWd, mHei, mLeft, mTop, mRow, tmPStr
    Dim rG As Range, mPath As String, tMp, mFile As String
'    On Error Resume Next
    mPath = ThisWorkbook.Path
    Set sH = ActiveSheet
    With sH

        mRow = .Cells(.Rows.Count, "C").End(3).Row
        If mRow < 2 Then Exit Sub
        For i = 2 To mRow
            If .Cells(i, "C") <> "" Then
                tmPStr = Dir(mPath & "\" & .Cells(i, "C") & ".jpg")
                If tmPStr <> "" Then
                    mFile = mPath & "\" & tmPStr
                    Set mSP = .Pictures.Insert(mFile)
                    With mSP
                        .ShapeRange.LockAspectRatio = msoFalse
                        .Width = sH.Range("B:B").Width - 6
                        .Height = sH.Rows(i).RowHeight - 6
                        .Top = sH.Cells(i, "B").Top + 3
                        .Left = sH.Cells(i, "B").Left + 3
                    End With
                End If
            End If
        Next i
    End With
End Sub

醉眼看尘世

Sub 批量插图()
    Dim mSP As Object, sH As Worksheet, mWd, mHei, mLeft, mTop, mRow, tmPStr
    Dim rG As Range, mPath As String, tMp, mFile As String
'    On Error Resume Next
    mPath = ThisWorkbook.Path
    Set sH = ActiveSheet
    With sH
        
        mRow = .Cells(.Rows.Count, "C").End(3).Row
        If mRow < 2 Then Exit Sub
        For i = 2 To mRow
            If .Cells(i, "C") <> "" Then
                tmPStr = Dir(mPath & "\" & .Cells(i, "C") & ".jpg")
                If tmPStr <> "" Then
                    mFile = mPath & "\" & tmPStr
                    Set mSP = .Pictures.Insert(mFile)
                    With mSP
                        .ShapeRange.LockAspectRatio = msoFalse
                        .Width = sH.Range("B:B").Width - 6
                        .Height = sH.Rows(i).RowHeight - 6
                        .Top = sH.Cells(i, "B").Top + 3
                        .Left = sH.Cells(i, "B").Left + 3
                    End With
                End If
            End If
        Next i
    End With
End Sub

ykcbf1100

醉眼看尘世 发表于 2024-7-24 23:43
Sub 批量插图()
    Dim mSP As Object, sH As Worksheet, mWd, mHei, mLeft, mTop, mRow, tmPStr
    Di ...

如果B列单元格中已经有图片，应该先删除图片吧。
你这个代码能正常插入图片，但是代码如果第二次再运行，则继续在同样的位置插入图片，这样，在一个位置上就有了几张图片了。最好是只插入一张图片。

caiqizhong21

醉眼看尘世 发表于 2024-7-24 23:43
Sub 批量插图()
    Dim mSP As Object, sH As Worksheet, mWd, mHei, mLeft, mTop, mRow, tmPStr
    Di ...

谢谢老师的代码够用了

醉眼看尘世

ykcbf1100 发表于 2024-7-25 07:12
如果B列单元格中已经有图片，应该先删除图片吧。
你这个代码能正常插入图片，但是代码如果第二次再运行 ...

是的。懒得写。呵呵

醉眼看尘世

ykcbf1100 发表于 2024-7-25 07:12
如果B列单元格中已经有图片，应该先删除图片吧。
你这个代码能正常插入图片，但是代码如果第二次再运行 ...

您说得是，完整的代码应该设计这个