Boyutlandırma Problemi

Kodla Büyü

5en

Üye
Mesajlar
2
Sub resimi_getir()
Dim resim As Object, i As Long, yol As String, dosya As String
Sheets("ÖNSAYFA").Select
yol = ThisWorkbook.Path & "\RESİMLER"
For i = 5 To Cells(65536, "x").End(xlUp).Row
For Each resim In ActiveSheet.Shapes
Next

If Dir(yol & "\" & Cells(i, "x").Value & ".jpg") <> "" Then
dosya = "\" & Cells(i, "x").Value & ".jpg"
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)
With Cells(i, "h")
t = .Top
l = .Left
w = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With

With P
.Top = t + 1
.Left = l + 1
.Width = w - 1
.Height = h - 1
End With
Set P = Nothing
End If
Next i

For i = 5 To Cells(65536, "y").End(xlUp).Row
For Each resim In ActiveSheet.Shapes
Next
If Dir(yol & "\" & Cells(i, "y").Value & ".jpg") <> "" Then
dosya = "\" & Cells(i, "y").Value & ".jpg"
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)
With Cells(i, "s")
t = .Top
l = .Left
w = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With
With P
.Top = t + 1
.Left = l + 1
.Width = w - 1
.Height = h - 1
End With
Set P = Nothing
End If
Next i
End Sub

Arkadaşlar elimde excel foto getirdiğim bu kod var fakat gelen fotolardan bazıları hücre dışına taşmakta yada hücrenin yarısını kaplamakta.Bu kodu düzenleyerek fotoların hücreyi doldurmasını nasıl sağlayabilirim
 
Tam bir cevap olmayacak bliyorum ama evdeki bilgisayarımda ms ofis olmadığından kodları deneyemedim. Meraktan baktım. Aşağıdaki bağlantıların faydası olacağını ümit ediyorum.
1-
2-
3-
 
Geri
Üst