Klasörden Otomatik Resim Çağırma

[farisakboga]

Excel ustalarına selamlar...

Amacım öğrencilerim için hazırladığım Zeka Oyunlarını bir şablona uygun çoğaltmak.
BulmacaData adlı klasörde png ya da jpg uzantılı bulmaca resimleri var. Her bulmaca türünü 1001,2001,3001,4001 gibi binli sayılarla adlandırdım. Örneğin sudoku 1001 ile başlayıp bulmaca sayısına göre 1999'a kadar gidebilir. diğer bulmacalar da öyle.
B4, C4, B7, C7, B10, C10 hücrelerine bulmaca türüne göre random gelen sayı, klasörden aynı ismi taşıyan bulmacayı çağırmalı. örneğin C4 hücresine random 2017 yazılmışsa 2017.jpg resmini C3 hücresine sığacak şekilde çağırmalı.
Aynı mantık tüm bulmacalar için geçerli olmalı.
Yardımcı olmanızı canı gönülden diliyorum. Teşekkür ederim.

 

[Asri]

Sayfanın kod bölümüne yapıştırın.
formül rnd de çalışmaz.
El yada kod ile rakamları değişirse resimler otomatik gelecektir.
Hücre sınırlaması yok.
Herhangi bir hücrede değer değiştiğinde bir üstteki hücreye resim gelecektir.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Row = 1 Then Exit Sub
    Set bulmacahcr = Cells(Target.Row - 1, Target.Column)
    
    For Each silinecek In ActiveSheet.Pictures
        If Not Intersect(silinecek.TopLeftCell, bulmacahcr) Is Nothing Then
            silinecek.Delete
        End If
    Next
    
    yol = ActiveWorkbook.Path & "\bulmacadata\"
    dosya = yol & Target.Value & ".png"
    
    If dosyavarmi(dosya) Then
        Set bulmacaresim = ActiveSheet.Shapes.AddPicture(dosya, True, True, bulmacahcr.Left, bulmacahcr.Top, bulmacahcr.MergeArea.Columns.Width, bulmacahcr.MergeArea.Rows.Height)
    End If
    
  End Sub

 

[systran]

örnek çalışmayı inceleyiniz.

 

[farisakboga]

Sayfanın kod bölümüne yapıştırın.
formül rnd de çalışmaz.
El yada kod ile rakamları değişirse resimler otomatik gelecektir.
Hücre sınırlaması yok.
Herhangi bir hücrede değer değiştiğinde bir üstteki hücreye resim gelecektir.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Row = 1 Then Exit Sub
    Set bulmacahcr = Cells(Target.Row - 1, Target.Column)
   
    For Each silinecek In ActiveSheet.Pictures
        If Not Intersect(silinecek.TopLeftCell, bulmacahcr) Is Nothing Then
            silinecek.Delete
        End If
    Next
   
    yol = ActiveWorkbook.Path & "\bulmacadata\"
    dosya = yol & Target.Value & ".png"
   
    If dosyavarmi(dosya) Then
        Set bulmacaresim = ActiveSheet.Shapes.AddPicture(dosya, True, True, bulmacahcr.Left, bulmacahcr.Top, bulmacahcr.MergeArea.Columns.Width, bulmacahcr.MergeArea.Rows.Height)
    End If
   
  End Sub

Asri Bey, çok teşekkür ederim daha önce de yardımcı olmuştunuz. Ancak yazdığınız kodu excel dosyasına ekleyemedim. Excel dosyasına ekleyip paylaşmanız mümkün mü?

 

[farisakboga]

örnek çalışmayı inceleyiniz.

Size de çok teşekkür ederim. Yazdığınız kod ve örnek dosya işime çok yarayacak. Tek sütünda gelen resimleri kağıttan tasarruf yapmak için 2 sütun şekline çevirebilir miyiz? 2 sütunda 5001, 6001,7001,8001 ile başlayan resimler gösterilsin.

 

[systran]

#3 nolu mesajdaki dosya güncellendi.
1000 2000
3000 4000
5000 6000
şeklinde Z sıralamayla varsa resimleri ekler.

 

[farisakboga]

#3 nolu mesajdaki dosya güncellendi.
1000 2000
3000 4000
5000 6000
şeklinde Z sıralamayla varsa resimleri ekler.

Çok teşekkür ederim. Minettarım.

 

[farisakboga]

Sayfanın kod bölümüne yapıştırın.
formül rnd de çalışmaz.
El yada kod ile rakamları değişirse resimler otomatik gelecektir.
Hücre sınırlaması yok.
Herhangi bir hücrede değer değiştiğinde bir üstteki hücreye resim gelecektir.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Row = 1 Then Exit Sub
    Set bulmacahcr = Cells(Target.Row - 1, Target.Column)
   
    For Each silinecek In ActiveSheet.Pictures
        If Not Intersect(silinecek.TopLeftCell, bulmacahcr) Is Nothing Then
            silinecek.Delete
        End If
    Next
   
    yol = ActiveWorkbook.Path & "\bulmacadata\"
    dosya = yol & Target.Value & ".png"
   
    If dosyavarmi(dosya) Then
        Set bulmacaresim = ActiveSheet.Shapes.AddPicture(dosya, True, True, bulmacahcr.Left, bulmacahcr.Top, bulmacahcr.MergeArea.Columns.Width, bulmacahcr.MergeArea.Rows.Height)
    End If
   
  End Sub

Arkadaşlar, Asri Bey'in yazdığı kodu bir türlü ilk mesajda paylaştığım excel dosyasına ekleyip çalıştıramadım yardımcı olabilir misiniz?

 

[Asri]

Çok sık giriş yapamıyorum.
Dosyanız ektedir.

 

[farisakboga]

Çok sık giriş yapamıyorum.
Dosyanız ektedir.

Çok teşekkür ederim.