Uma possibilidade
Reinaldo, muito obrigado por ajudar. A única questão que ainda não funcionou foi redimensionar a imagem e enviá-la para seu quadro em referência! A imagem é inserida e redimensionada, porém fica em uma localização qualquer da planilha!
Jair, troque a rotina que o Reinaldo postou pela a abaixo, é a mesma, só fiz alguns ajustes, teste e veja se é isto :
Sub IncluiImg()
Dim YourPic As Picture
Dim sPath As String, sDir As String
Dim myPic As Variant
Dim Celula As String
sPath = ThisWorkbook.Path
'Acrescenta "" ao caminho se necessario
If Right(sPath, 1) <> "" Then
sPath = sPath & ""
Else
sPath = sPath
End If
'Altera o diretorio de "trabalho" para o caminho sPath
ChDir sPath
For x = 8 To 200 Step 14
If Cells(x, 2) <> "" Then
'Armazenamos o endereço da celula a inserir a foto
Celula = Cells(x, 2).Address(0, 0)
sDir = Dir(sPath & Cells(x, 2) & ".jpg", vbArchive)
If sDir <> "" Then
With ActiveSheet.Range(Celula)
.Select
'Inserimos a foto
Set YourPic = .Parent.Pictures.Insert(sDir)
'Definimos o local a ser inserido de acordo com as
'coordenadas da Celula
YourPic.Top = Range(Celula).Top
YourPic.Left = Range(Celula).Left
YourPic.ShapeRange.LockAspectRatio = msoFalse
'Altera as dimensões da imagem para o quadrado podendo "distorcer" a imagem
YourPic.ShapeRange.Height = 150.22
YourPic.ShapeRange.Width = 229.61
End With
End If
If Cells(x, 7) <> "" Then
'Armazenamos o endereço da celula a inserir a foto
Celula = Cells(x, 7).Address(0, 0)
sDir = Dir(sPath & Cells(x, 7) & ".jpg", vbArchive)
If sDir <> "" Then
With ActiveSheet.Range(Celula)
.Select
'Inserimos a foto
Set YourPic = .Parent.Pictures.Insert(sDir)
'Definimos o local a ser inserido de acordo com as
'coordenadas da Celula
YourPic.Top = Range(Celula).Top
YourPic.Left = Range(Celula).Left
YourPic.ShapeRange.LockAspectRatio = msoFalse
YourPic.ShapeRange.Height = 150.22
YourPic.ShapeRange.Width = 229.61
End With
End If
End If
End If
Next
End Sub
[]s
Postado : 14/02/2018 11:09 am