Resim Ekleme ve Boyutlandırma hakkında

[Nikolayco]

Arkadaşlar Merhaba şöyle bir tablo ile uğraşıyorum.

Bir yedek parça listem var 600 adet parça.

Y.Parça listesi yerleştirerek bir format hazırladım
yalnız yanlarına resimlerinde gelmesini istiyorum elimde aşağıdaki gibi bir kod var macroyu çalıştırdığımda resimleri de alıyor ama otomatik olarak boyutlandırmayı çözemedim bir türlü yardımcı olabilecek varsa çok sevinirim.

Problemim otomatik hücreye göre boyutlandırma

KOD:

Sub resimleri_al()
Dim resim As Shape, i As Long, yol As String, dosya As String
Sheets("RESİMLER").Select
yol = ThisWorkbook.Path
For Each resim In ActiveSheet.Shapes
If resim.Name <> "Button 5" Then resim.Delete
Next
For i = 2 To Cells(65536, "A").End(xlUp).Row
Cells(i, "B").Select
If Dir(yol & "\" & Cells(i, "A").Value & ".jpg") <> "" Then
dosya = "\" & Cells(i, "A").Value & ".jpg"
End If
If Dir(yol & "\" & Cells(i, "A").Value & ".gif") <> "" Then
dosya = "\" & Cells(i, "A").Value & ".gif"
End If
ActiveSheet.Pictures.Insert (yol & dosya)


Next i
MsgBox "İşlem tamamdır.", vbOKOnly + vbInformation, Application.UserName

End Sub

 

[Orion1]

Sub resimleri_al()
Dim resim As Shape, i As Long, yol As String, dosya As String
Sheets("RESİMLER").Select
yol = ThisWorkbook.Path
For Each resim In ActiveSheet.Shapes
    If resim.Name <> "Button 5" Then resim.Delete
Next
For i = 2 To Cells(65536, "A").End(xlUp).Row
    Cells(i, "B").Select
    If Dir(yol & "\" & Cells(i, "A").Value & ".jpg") <> "" Then
        dosya = "\" & Cells(i, "A").Value & ".jpg"
    End If
    If Dir(yol & "\" & Cells(i, "A").Value & ".gif") <> "" Then
        dosya = "\" & Cells(i, "A").Value & ".gif"
    End If
    ActiveSheet.Pictures.Insert(yol & dosya).Select
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Width = Range("B" & i).Width
    Selection.ShapeRange.Height = Range("B" & i).Height
Next i
Range("A1").Select
MsgBox "İşlem tamamdır.", vbOKOnly + vbInformation, Application.UserName

End Sub

 

[Nikolayco]

Bu kod çok işime yaradı çok teşekkür ederim.

 

[Nikolayco]

Sayın uzmanlarım konuya acil olarak el atabilirmisiniz rica ederim. Çok müğşkül durumdayım müdürüm benden cevap bekliyor

http://www.excel.web.tr/showthread.php?t=76821