Guru do Excel e Power BI

Option Explicit

'Autor: Domenic Domenic (MrExcel MVP)
'Fonte: https://www.mrexcel.com/forum/excel-questions/611678-macro-zoom-picture.html

Private Sub Picture_Click()

    Static Dict As Dictionary
    Static MyPics() As Variant
    Static Cnt As Long
    Static c As Long
    
    Dim SHP As Shape
    
    Cnt = Cnt + 1
    
    If Cnt = 1 Then
        Set Dict = CreateObject("Scripting.Dictionary")
    End If
    
    Set SHP = Me.Shapes(Application.Caller)
    
    If Not Dict.Exists(SHP.Name) Then
        c = c + 1
        Dict.Add SHP.Name, c
        ReDim Preserve MyPics(1 To 2, 1 To c)
        MyPics(1, c) = SHP.Name
        MyPics(2, c) = True
    End If
    
    If MyPics(2, Dict.Item(SHP.Name)) = True Then
        MyPics(2, Dict.Item(SHP.Name)) = False
        SHP.ScaleHeight 1.5, msoTrue 'aumentar a altura para 50%
        SHP.ScaleWidth 1.5, msoTrue 'aumentar a largura para 50%
    Else
       MyPics(2, Dict.Item(SHP.Name)) = True
        SHP.ScaleHeight 1, msoTrue 'escala para altura original
        SHP.ScaleWidth 1, msoTrue 'escala para largura original
    End If

End Sub

Sub AssignMacro()
'Click com o direito do mouse e seleciona a opção Atribuir Macro
    Dim SHP As Shape
    For Each SHP In Plan1.Shapes 'Altere o nome da guia caso necessário
        If SHP.Type = 13 Then 'imagem
            SHP.OnAction = "Plan1.Picture_Click"
        End If
    Next SHP
End Sub

Sub ResetToOriginalSize()
'Coloque esse código dentro de um Módulo comum
    Dim SHP As Shape
    For Each SHP In Plan1.Shapes
        If SHP.Type = 13 Then 'imagem
            SHP.ScaleHeight 1, msoTrue 'scale to original height
            SHP.ScaleWidth 1, msoTrue 'scale to original width
        End If
    Next SHP
End Sub

Private Sub Workbook_Open()
'Coloque esse código dentro do módulo de EstaPasta_de_trabalho
    Call ResetToOriginalSize
End Sub