Hücreye Resim Çağırma

[kadir78]

Excel çalışma kitabının içinde 7 adet çalışma sayfası bulunuyor. Birinci çalışma sayfasındaki butona tıklamak kaydıyla, diğer çalışma sayfalarının (sayfa 2, sayfa3, sayfa 4, sayfa 5, sayfa 6, sayfa 7) A1 hücrelerinin içine sığdırmak kaydıyla, klasör içerisinden resim çağırmak mümkünmüdür.

Not: Resimlerin yolu örnek olarak C:\Resim klasörünün içerindeki 1.jpg, 2.jpg, 3.jpg, 4.jpg, 5.jpg, 6.jpg olarak tanımlanabilir.

 

[kadir78]

Cevap veren yokmu, Üstadlar.

 

[Korhan Ayhan]

Aşağıdaki kodu kendinize göre uyarlayıp kullanabilirsiniz.

Sub RESİMLERİ_AKTAR()
    Dim Sayfa(), X As Byte, Yol As String, Resim As Object
    
    Yol = ThisWorkbook.Path & "\Resimler\"
    Sayfa = Array("Sayfa1", "Sayfa2", "Sayfa3", "Sayfa4", "Sayfa5", "Sayfa6", "Sayfa7")

    For X = 0 To UBound(Sayfa)
        Sheets(Sayfa(X)).Select
        Range("A1").Select
        Sheets(Sayfa(X)).Pictures.Delete
        Set Resim = Sheets(Sayfa(X)).Pictures.Insert(Yol & X + 1 & ".JPG")
        With Resim
            .ShapeRange.LockAspectRatio = msoFalse
            .Height = ActiveCell.Height
            .Width = ActiveCell.Width
            .Top = ActiveCell.Top
            .Left = ActiveCell.Left
            .Placement = xlMoveAndSize
        End With
    Next

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[kadir78]

Korhan Bey. Kodları düzenledim ama başarılı olamadım. Sürekli Subscript Out Of The Range ve 400 hatalarını veriyor. Resimler C:\Resimler\1.jpg C:\Resimler\2.jpg gibi 6 adet resim var. Yardımcı olurmusunuz lütfen.

Sub ResimAktar()
Dim Sayfa(), X As Byte, Yol As String, Resim As Object

Yol = ThisWorkbook.Path & "C:\Resimler"
Sayfa = Array("2.Sayfa", "3.Sayfa", "4.Sayfa", "5.Sayfa", "6.Sayfa5", "7.Sayfa")

For X = 0 To UBound(Sayfa)
Sheets(Sayfa(X)).Select
Range("B9").Select
Sheets(Sayfa(X)).Pictures.Delete
Set Resim = Sheets(Sayfa(X)).Pictures.Insert(Yol & X + 1 & ".JPG")
With Resim
.ShapeRange.LockAspectRatio = msoFalse
.Height = ActiveCell.Height
.Width = ActiveCell.Width
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Placement = xlMoveAndSize
End With
Next

MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Korhan Ayhan]

"YOL" tanımlamasını aşağıdaki gibi düzenleyip deneyin.

Yol = "C:\Resimler\"