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
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