Как изменить отображаемое изображение после повторного нажатия кнопки в Excel

Question

Моя проблема в том, что когда я нажимаю командную кнопку, она показывает изображение, но когда я нажимаю ее снова, командная кнопка дублирует отображаемое изображение.

Private Sub CommandButton1_Click()
    Dim pictureNameColumn   As String 'column where picture name is found
    Dim picturePasteColumn  As String 'column where picture is to be pasted

    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 pathForPicture      As String 'path of pictures

    pictureNameColumn = "A"
    picturePasteColumn = "E"

    pictureRow = 2 'starts from this row

    'error handler
    On Error GoTo Err_Handler

    'find row of the last cell in use in the column where picture names are
    lastPictureRow = Cells(Rows.Count, pictureNameColumn).End(xlUp).Row

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

    pathForPicture = "C:\Users\drawing\Desktop\pic\"
    'loop till last row
    Do While (pictureRow <= lastPictureRow)

pictureName = Cells(pictureRow, "A") 'This is the picture name

'if picture name is not blank then
If (pictureName <> vbNullString) Then

    'check if pic is present

    'Start If block with .JPG
    If (Dir(pathForPicture & pictureName & ".jpg") <> vbNullString) Then

        Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
        ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".jpg").Select 'Path to where pictures are stored

        With Selection
            .Left = Cells(pictureRow, picturePasteColumn).Left
            .Top = Cells(pictureRow, picturePasteColumn).Top
            .ShapeRange.LockAspectRatio = msoFalse
            .ShapeRange.Height = 100#
            .ShapeRange.Width = 130#
            .ShapeRange.Rotation = 0#
        End With
    'End If block with .JPG

    'Start ElseIf block with .PNG
    ElseIf (Dir(pathForPicture & pictureName & ".png") <> vbNullString) Then

        Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
        ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".png").Select 'Path to where pictures are stored

        With Selection
            .Left = Cells(pictureRow, picturePasteColumn).Left
            .Top = Cells(pictureRow, picturePasteColumn).Top
            .ShapeRange.LockAspectRatio = msoFalse
            .ShapeRange.Height = 100#
            .ShapeRange.Width = 130#
            .ShapeRange.Rotation = 0#
        End With
    'End ElseIf block with .PNG

    'Start ElseIf block with .BMP
    ElseIf (Dir(pathForPicture & pictureName & ".bmp") <> vbNullString) Then

        Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
        ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".bmp").Select 'Path to where pictures are stored

        With Selection
            .Left = Cells(pictureRow, picturePasteColumn).Left
            .Top = Cells(pictureRow, picturePasteColumn).Top
            .ShapeRange.LockAspectRatio = msoFalse
            .ShapeRange.Height = 100#
            .ShapeRange.Width = 130#
            .ShapeRange.Rotation = 0#
        End With
    'End ElseIf block with .BMP

    Else
        'picture name was there, but no such picture
        Cells(pictureRow, picturePasteColumn) = "No Picture Found"
    End If

Else
'picture name cell was blank
End If
'increment row count
pictureRow = pictureRow + 1
    Loop

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

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

End Sub

То, что я хочу, это когда я снова нажимаю кнопку, предыдущее изображение будет просто заменено новым основанием изображения в столбце A.

Answer 1

Вам необходимо найти существующее изображение на основе его положения, а затем удалить его, прежде чем вставлять следующее изображение.

Зациклите все изображения на листе и проверьте их положение - если вы найдете то, которое соответствует тому, где вы хотите вставить новое изображение, удалите его.

Sub tester()
    DeletePicFromCell Range("I3")
End Sub


Sub DeletePicFromCell(c As Range)
    Const MARGIN As Long = 10 '<< how far the picture can be out of place
    Dim shp
    For Each shp In c.Parent.Shapes
        If Abs(shp.Left - c.Left) < MARGIN And _
           Abs(shp.Top - c.Top) < MARGIN Then
            shp.Delete
            Exit For '<< done checking
        End If
    Next shp
End Sub

Кстати, вам не нужно проверять все эти блоки на наличие различных расширений: при условии, что все потенциальные совпадения являются изображениями, вы можете сделать что-то вроде

Dim fName

fName = Dir(pathForPicture & pictureName & ".*") '<< match any extension

If Len(fName)>0 Then

    'Have a match
    'Insert image from pathForPicture & fName

End If

РЕДАКТИРОВАТЬ: ваш оригинальный код переработан

Private Sub CommandButton1_Click()

    Const COL_PIC_NAME As Long = 1   'column where picture name is found
    Const COL_PIC_PASTE As Long = 5  'column where picture is to be pasted
    Const PIC_PATH As String = "C:\Users\drawing\Desktop\pic\"

    Dim pictureName         As String 'picture name
    Dim pictureFile         As String 'picture file
    Dim pictureRow          As Long   'current picture row to be processed
    Dim sht As Worksheet
    Dim picCell As Range

    Set sht = ActiveSheet

    For pictureRow = 2 To sht.Cells(sht.Rows.Count, COL_PIC_NAME).End(xlUp).Row

        pictureName = sht.Cells(pictureRow, COL_PIC_NAME) 'This is the picture name
        If Len(pictureName) > 0 Then
            pictureFile = Dir(PIC_PATH & pictureName & ".*", vbNormal) 'is there a matching file?

            If Len(pictureFile) > 0 Then
                Set picCell = sht.Cells(pictureRow, COL_PIC_PASTE)
                DeletePicFromCell picCell 'delete any previous picture
                With sht.Pictures.Insert(PIC_PATH & pictureFile)
                    .Left = picCell.Left
                    .Top = picCell.Top
                    .ShapeRange.LockAspectRatio = msoFalse
                    .Height = 100
                    .Width = 130
                End With
            End If 'have picture

        End If 'have picname

    Next pictureRow

End Sub