Excel 如何按给定单元格名称将图片插入单元格的注释中

由于Macromarc，此问题已得到解决

我的代码有一个问题，那就是它只是把图片放进了一个单元格，而图片的大小不正确。当我过滤我的数据时，图片总是相互折叠，看起来也不太好

下面是正确的代码，感谢Macromarc

---

我重写了一些其他代码，并重构了一个函数

经过测试，基本上对我有效。如有任何问题，请询问：

Private Sub GrabImagePasteIntoCell()

Const pictureNameColumn As String = "A"     'column where picture name is found
Const picturePasteColumn As String = "J"     'column where picture is to be pasted
Const pathForPicture    As String = "M:\Users\Dan\Pictures\LabPics\"    'path of pictures

Dim pictureFile         As String
Dim pictureName         As String 'picture name
Dim lastPictureRow      As Long   'last row in use where picture names are
Dim pictureRow          As Long   'current picture row to be processed
Dim picturePasteCell    As Range
pictureRow = 3 'starts from this row

On Error GoTo Err_Handler
Dim ws As Worksheet
Set ws = ActiveSheet    'replace with better qualification
lastPictureRow = ws.Cells(ws.Rows.Count, pictureNameColumn).End(xlUp).Row

'stop screen updates while macro is running
Application.ScreenUpdating = False

'loop till last picture row
Do While (pictureRow <= lastPictureRow)
    pictureName = ws.Cells(pictureRow, pictureNameColumn).Value2
    If (pictureName <> vbNullString) Then
        'check if pic is present
        pictureFile = pathForPicture & pictureName
        Set picturePasteCell = ws.Cells(pictureRow, picturePasteColumn)

        If (Dir(pictureFile & ".jpg") <> vbNullString) Then
            insertPictureToComment pictureFile & ".jpg", picturePasteCell, 41, 41

        ElseIf (Dir(pictureFile & ".png") <> vbNullString) Then
            insertPictureToComment pictureFile & ".png", picturePasteCell, 100, 130

        ElseIf (Dir(pictureFile & ".bmp") <> vbNullString) Then
            insertPictureToComment pictureFile & ".bmp", picturePasteCell, 100, 130

        Else
            'picture name was there, but no such picture
            picturePasteCell.Value2 = "No Picture Found"
        End If
    Else
        'picture name cell was blank
    End If

    pictureRow = pictureRow + 1
Loop

On Error GoTo 0

Exit_Sub:
ws.Range("A10").Select
Application.ScreenUpdating = True
Exit Sub

Err_Handler:
MsgBox "Error encountered. " & Err.Description, vbCritical, "Error"
GoTo Exit_Sub

End Sub

---

我重写了一些其他代码，并重构了一个函数

经过测试，基本上对我有效。如有任何问题，请询问：

Private Sub GrabImagePasteIntoCell()

Const pictureNameColumn As String = "A"     'column where picture name is found
Const picturePasteColumn As String = "J"     'column where picture is to be pasted
Const pathForPicture    As String = "M:\Users\Dan\Pictures\LabPics\"    'path of pictures

Dim pictureFile         As String
Dim pictureName         As String 'picture name
Dim lastPictureRow      As Long   'last row in use where picture names are
Dim pictureRow          As Long   'current picture row to be processed
Dim picturePasteCell    As Range
pictureRow = 3 'starts from this row

On Error GoTo Err_Handler
Dim ws As Worksheet
Set ws = ActiveSheet    'replace with better qualification
lastPictureRow = ws.Cells(ws.Rows.Count, pictureNameColumn).End(xlUp).Row

'stop screen updates while macro is running
Application.ScreenUpdating = False

'loop till last picture row
Do While (pictureRow <= lastPictureRow)
    pictureName = ws.Cells(pictureRow, pictureNameColumn).Value2
    If (pictureName <> vbNullString) Then
        'check if pic is present
        pictureFile = pathForPicture & pictureName
        Set picturePasteCell = ws.Cells(pictureRow, picturePasteColumn)

        If (Dir(pictureFile & ".jpg") <> vbNullString) Then
            insertPictureToComment pictureFile & ".jpg", picturePasteCell, 41, 41

        ElseIf (Dir(pictureFile & ".png") <> vbNullString) Then
            insertPictureToComment pictureFile & ".png", picturePasteCell, 100, 130

        ElseIf (Dir(pictureFile & ".bmp") <> vbNullString) Then
            insertPictureToComment pictureFile & ".bmp", picturePasteCell, 100, 130

        Else
            'picture name was there, but no such picture
            picturePasteCell.Value2 = "No Picture Found"
        End If
    Else
        'picture name cell was blank
    End If

    pictureRow = pictureRow + 1
Loop

On Error GoTo 0

Exit_Sub:
ws.Range("A10").Select
Application.ScreenUpdating = True
Exit Sub

Err_Handler:
MsgBox "Error encountered. " & Err.Description, vbCritical, "Error"
GoTo Exit_Sub

End Sub

---

嗨，我不能给出一个完整的答案，但是在评论中插入图片的代码是：

myRange.comment.Shape.Fill.UserPicture“C:\Users\Public\Pictures\Sample Pictures\jummy.jpg”

我试着把它扔进去，修改一些措辞，但对我来说不起作用。我花了一些时间来看看这个，并测试了一个subHi Danny，示例答案有帮助吗？很高兴提供帮助：-）嗨，我不能给出一个完整的答案，但是在注释中插入图像的代码是：

myRange.comment.Shape.Fill.UserPicture“C:\Users\Public\Pictures\Sample Pictures\chummer.jpg”

我试图把它扔进去，并修改了一些措辞，但这对我来说不起作用。我花了一些时间来研究这个问题，并测试了一个subHi Danny，示例答案有帮助吗？很高兴帮助：-）

Private Sub GrabImagePasteIntoCell()

Const pictureNameColumn As String = "A"     'column where picture name is found
Const picturePasteColumn As String = "J"     'column where picture is to be pasted
Const pathForPicture    As String = "M:\Users\Dan\Pictures\LabPics\"    'path of pictures

Dim pictureFile         As String
Dim pictureName         As String 'picture name
Dim lastPictureRow      As Long   'last row in use where picture names are
Dim pictureRow          As Long   'current picture row to be processed
Dim picturePasteCell    As Range
pictureRow = 3 'starts from this row

On Error GoTo Err_Handler
Dim ws As Worksheet
Set ws = ActiveSheet    'replace with better qualification
lastPictureRow = ws.Cells(ws.Rows.Count, pictureNameColumn).End(xlUp).Row

'stop screen updates while macro is running
Application.ScreenUpdating = False

'loop till last picture row
Do While (pictureRow <= lastPictureRow)
    pictureName = ws.Cells(pictureRow, pictureNameColumn).Value2
    If (pictureName <> vbNullString) Then
        'check if pic is present
        pictureFile = pathForPicture & pictureName
        Set picturePasteCell = ws.Cells(pictureRow, picturePasteColumn)

        If (Dir(pictureFile & ".jpg") <> vbNullString) Then
            insertPictureToComment pictureFile & ".jpg", picturePasteCell, 41, 41

        ElseIf (Dir(pictureFile & ".png") <> vbNullString) Then
            insertPictureToComment pictureFile & ".png", picturePasteCell, 100, 130

        ElseIf (Dir(pictureFile & ".bmp") <> vbNullString) Then
            insertPictureToComment pictureFile & ".bmp", picturePasteCell, 100, 130

        Else
            'picture name was there, but no such picture
            picturePasteCell.Value2 = "No Picture Found"
        End If
    Else
        'picture name cell was blank
    End If

    pictureRow = pictureRow + 1
Loop

On Error GoTo 0

Exit_Sub:
ws.Range("A10").Select
Application.ScreenUpdating = True
Exit Sub

Err_Handler:
MsgBox "Error encountered. " & Err.Description, vbCritical, "Error"
GoTo Exit_Sub

End Sub

Function insertPictureToComment(pictureFilePath As String, _
                            pictureRange As Range, _
                            commentHeight As Long, _
                            commentWidth As Long)

Dim picComment As Comment
If pictureRange.Comment Is Nothing Then
    Set picComment = pictureRange.AddComment
Else
    Set picComment = pictureRange.Comment
End If

With picComment.Shape
    .Height = commentHeight
    .Width = commentWidth
    .LockAspectRatio = msoFalse
    .Fill.UserPicture pictureFilePath
End With

End Function