Contribuindo.
Experimente:
Option Explicit
Sub test()
Dim YourPic As Picture
Dim sPath As String, sDir As String, Img As String, ed As String
'Dim myPic As Variant
Dim myrng As Range, cel As Range
sPath = ThisWorkbook.Path 'Altere aqui para o seu caminho
'Acrescenta "" ao caminho se necessario
If Right(sPath, 1) <> "" Then
sPath = sPath & ""
Else
sPath = sPath
End If
Set myrng = Sheets("Arquivos").Range("A1:M18")
'Altera o diretorio de "trabalho" para o caminho sPath
ChDir sPath
sDir = Dir("*.jpg")
Do While sDir <> ""
Img = Left(sDir, Len(sDir) - 4)
For Each cel In myrng
If Img = cel.Value Then
ed = cel.Offset(0, -2).Address
With ActiveSheet.Range(ed)
Set YourPic = .Parent.Pictures.Insert(sPath & sDir)
YourPic.Top = .Top
YourPic.ShapeRange.LockAspectRatio = msoFalse
YourPic.ShapeRange.Height = 45.5
YourPic.ShapeRange.Width = 95.5
'YourPic.ShapeRange.ScaleWidth 0.45, msoFalse, msoScaleFromTopLeft
'YourPic.ShapeRange.ScaleHeight 0.45, msoFalse, msoScaleFromTopLeft
YourPic.Left = .Left
End With
End If
Next
sDir = Dir
Loop
End Sub
Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel
Postado : 20/03/2015 5:27 pm