Excel Repetir a imagem para linhas abaixo - VBA Macro

[DiegoVieira46]

Boa tarde, prezados.

 

Utilizo uma fórmula VBA para inserir um código em uma linha e ele me trazer uma imagem local armazenada em meu computador. O recurso funciona bem, porém necessito repetir o código em alguns oportunidades, porém a imagem não se mantém na célula. Para facilitar o entendimento, segue cenário que ocorre e cenário que preciso. 

 

Podem me auxiliar, por gentileza?

 

Necessito que ao inserir um mesmo código em outra linha, a imagem seja exibida corretamente em todas as linhas.

 

Utilizo o código abaixo:

Public Function getImage(ByVal sCode As String) As String

Dim sFile As String
Dim oSheet As Worksheet
Dim oCell As Range
Dim oImage As Shape

Set oCell = Application.Caller ' Célula onde a função foi chamada
Set oSheet = oCell.Parent      ' Planilha que chamou a função

' Procura por uma imagem existente identificada pelo código (que precisa ser único!)
Set oImage = Nothing
For i = 1 To oSheet.Shapes.Count
    If oSheet.Shapes(i).Name = sCode Then
        Set oImage = oSheet.Shapes(i)
        Exit For
    End If
Next i

' Se ainda não existir uma imagem com o código, carrega do arquivo e cria-a.
' A imagem já é posicionada na exata posição da célula onde a função foi chamada.
If oImage Is Nothing Then
    sFile = "c:\temp\sopt\" & sCode & ".jpg"
    Set oImage = oSheet.Shapes.AddPicture(sFile, msoCTrue, msoCTrue, oCell.Left, oCell.Top, oCell.Width, oCell.Height)
    oImage.Name = sCode

' Caso contrário, se a imagem já existir, garante que ela se posiciona e cabe exatamente dentro da célula
' (apenas para o caso do usuário ter movido ou redimensionado manualmente a imagem sem querer)
Else
    With oImage
        .Left = oCell.Left
        .Top = oCell.Top
        .Width = oCell.Width
        .Height = oCell.Height
    End With
End If

' Retorna nada para a célula (afinal, esta é somente uma função de auxílio)
getImage = ""
End Function

[Basole]

Experimente retirar da funcao o trecho no codigo que procura por uma imagem existente.

 

Public Function getImage(ByVal sCode As String) As String

Dim sFile As String
Dim oSheet As Worksheet
Dim oCell As Range
Dim oImage As Shape

Set oCell = Application.Caller ' Célula onde a função foi chamada
Set oSheet = oCell.Parent      ' Planilha que chamou a função

' Se ainda não existir uma imagem com o código, carrega do arquivo e cria-a.
' A imagem já é posicionada na exata posição da célula onde a função foi chamada.
If oImage Is Nothing Then
    sFile = "c:\temp\sopt\" & sCode & ".jpg"
    Set oImage = oSheet.Shapes.AddPicture(sFile, msoCTrue, msoCTrue, oCell.Left, oCell.Top, oCell.Width, oCell.Height)
    oImage.Name = sCode

' Caso contrário, se a imagem já existir, garante que ela se posiciona e cabe exatamente dentro da célula
' (apenas para o caso do usuário ter movido ou redimensionado manualmente a imagem sem querer)
Else
    With oImage
        .Left = oCell.Left
        .Top = oCell.Top
        .Width = oCell.Width
        .Height = oCell.Height
    End With
End If

' Retorna nada para a célula (afinal, esta é somente uma função de auxílio)
 getImage = ""
End Function

 

[DiegoVieira46]

Perfeito meu amigo.

 

O código atendeu exatamente conforme eu precisava.

 

Muito obrigado.