• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Makro ile otomatik resim çağırma

  • Konbuyu başlatan Konbuyu başlatan crazy34
  • Başlangıç tarihi Başlangıç tarihi
C

crazy34

Katılım
5 Ocak 2017
Mesajlar
19
Excel Vers. ve Dili
2013 türkçe
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [C3]) Is Nothing Then Exit Sub

ActiveSheet.DrawingObjects.Delete


'resim yolunun bulunması

Dim resimyolu1 As Variant
Dim resimyolu2 As Variant
Dim resimyolu3 As Variant
Dim resimyolu4 As Variant
Dim resimyolu5 As Variant
Dim resimyolu6 As Variant
Dim resimyolu7 As Variant
Dim resimyolu8 As Variant
Dim resimyolu9 As Variant
Dim resimyolu10 As Variant
Dim teklifyolu As Variant

Dim resim1 As Object
Dim resim2 As Object
Dim resim3 As Object
Dim resim4 As Object
Dim resim5 As Object
Dim resim6 As Object
Dim resim7 As Object
Dim resim8 As Object
Dim resim9 As Object
Dim resim10 As Object
Dim teklif As Object


resimyolu1 = ActiveWorkbook.Path & "\" & "Resimler" & "\" & [C3] & " " & "(1)" & ".jpg"
resimyolu2 = ActiveWorkbook.Path & "\" & "Resimler" & "\" & [C3] & " " & "(2)" & ".jpg"
resimyolu3 = ActiveWorkbook.Path & "\" & "Resimler" & "\" & [C3] & " " & "(3)" & ".jpg"
resimyolu4 = ActiveWorkbook.Path & "\" & "Resimler" & "\" & [C3] & " " & "(4)" & ".jpg"
resimyolu5 = ActiveWorkbook.Path & "\" & "Resimler" & "\" & [C3] & " " & "(5)" & ".jpg"
resimyolu6 = ActiveWorkbook.Path & "\" & "Resimler" & "\" & [C3] & " " & "(6)" & ".jpg"
resimyolu7 = ActiveWorkbook.Path & "\" & "Resimler" & "\" & [C3] & " " & "(7)" & ".jpg"
resimyolu8 = ActiveWorkbook.Path & "\" & "Resimler" & "\" & [C3] & " " & "(8)" & ".jpg"
resimyolu9 = ActiveWorkbook.Path & "\" & "Resimler" & "\" & [C3] & " " & "(9)" & ".jpg"
resimyolu10 = ActiveWorkbook.Path & "\" & "Resimler" & "\" & [C3] & " " & "(10)" & ".jpg"
teklifyolu = ActiveWorkbook.Path & "\" & "Resimler" & "\" & [C3] & "teklif" & ".jpg"

'resmi oluştur
Set resim1 = ActiveSheet.Pictures.Insert(resimyolu1)
Set resim2 = ActiveSheet.Pictures.Insert(resimyolu2)
Set resim3 = ActiveSheet.Pictures.Insert(resimyolu3)
Set resim4 = ActiveSheet.Pictures.Insert(resimyolu4)
Set resim5 = ActiveSheet.Pictures.Insert(resimyolu5)
Set resim6 = ActiveSheet.Pictures.Insert(resimyolu6)
Set resim7 = ActiveSheet.Pictures.Insert(resimyolu7)
Set resim8 = ActiveSheet.Pictures.Insert(resimyolu8)
Set resim9 = ActiveSheet.Pictures.Insert(resimyolu9)
Set resim10 = ActiveSheet.Pictures.Insert(resimyolu10)
Set teklif = ActiveSheet.Pictures.Insert(teklifyolu)

'resmi boyutlandır
With Range("G6:g8")
resim1.Top = .Top
resim1.Left = .Left
resim1.Height = 100
resim1.Width = 100
End With

With Range("h6:H8")
resim2.Top = .Top
resim2.Left = .Left
resim2.Height = 100
resim2.Width = 100
End With

With Range("g9:g11")
resim3.Top = .Top
resim3.Left = .Left
resim3.Height = 100
resim3.Width = 100
End With

With Range("h9:h11")
resim4.Top = .Top
resim4.Left = .Left
resim4.Height = 100
resim4.Width = 100
End With

With Range("G12:g14")
resim5.Top = .Top
resim5.Left = .Left
resim5.Height = 100
resim5.Width = 100
End With

With Range("h12:h14")
resim6.Top = .Top
resim6.Left = .Left
resim6.Height = 100
resim6.Width = 100
End With

With Range("G15:g17")
resim7.Top = .Top
resim7.Left = .Left
resim7.Height = 100
resim7.Width = 100
End With

With Range("h15:h17")
resim8.Top = .Top
resim8.Left = .Left
resim8.Height = 100
resim8.Width = 100
End With

With Range("G18:g20")
resim9.Top = .Top
resim9.Left = .Left
resim9.Height = 100
resim9.Width = 100
End With

With Range("h18:h20")
resim10.Top = .Top
resim10.Left = .Left
resim10.Height = 100
resim10.Width = 100
End With

With Range("k6:q20")
teklif.Top = .Top
teklif.Left = .Left
teklif.Height = 210
teklif.Width = 250
End With

End Sub

elimde böyle bir kod var bunun daha kolay bir yolu var mı?

ve burada bir tane resim olmasa hata veriyor. olan resimleri ekleyip olmayanları eklememesi için ne yapabilirim?
 
Örnek dosya eklerseniz döngü ile kodu kısaltalım.
Ya da aşağıdaki şekilde deneyin.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [C3]) Is Nothing Then Exit Sub

ActiveSheet.DrawingObjects.Delete


'resim yolunun bulunması

Dim resimyolu1 As Variant
Dim teklifyolu As Variant

Dim resim1 As Object

Dim teklif As Object

a = 6
b = 8
For i = 1 To 10
resimyolu1 = ActiveWorkbook.Path & "\Resimler\" & [C3] & " (" & i & ").jpg"



'resmi oluştur
Set resim1 = ActiveSheet.Pictures.Insert(resimyolu1)

With Range("G" & a & ":g" & b)
resim1.Top = .Top
resim1.Left = .Left
resim1.Height = 100
resim1.Width = 100
End With

With Range("h " & a & ":H" & b)
resim2.Top = .Top
resim2.Left = .Left
resim2.Height = 100
resim2.Width = 100
End With
a = a + 3
b = b + 3

Next
teklifyolu = ActiveWorkbook.Path & "\" & "Resimler" & "\" & [C3] & "teklif" & ".jpg"
Set teklif = ActiveSheet.Pictures.Insert(teklifyolu)

'resmi boyutlandır



With Range("k6:q20")
teklif.Top = .Top
teklif.Left = .Left
teklif.Height = 210
teklif.Width = 250
End With

End Sub
 
DIR komutu ile resim var mı kontrol edilir, sonrasında resim varsa eklenir ve boyutlandırılır. Bütün resimler için aynı döngüyü uygulayın.

Kod: 
If Dir(Resimyolu1) <> "" Then
Set resim1 = ActiveSheet.Pictures.Insert(resimyolu1)
With Range("G6:g8")
resim1.Top = .Top
resim1.Left = .Left
resim1.Height = 100
resim1.Width = 100
End With
 
örnek dosya şu şekildedir

Resim Çağırma

excel de a,b,c,d sayfaları var ve her sayfada C3 yerine yazdığım harfe göre Resimler klasöründen yazdığım harfe uygun olan resimler excel de resim için ayırdığım bölmelere gelsin istiyorum.

askm
askm' Alıntı:
Örnek dosya eklerseniz döngü ile kodu kısaltalım.
Ya da aşağıdaki şekilde deneyin.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [C3]) Is Nothing Then Exit Sub

ActiveSheet.DrawingObjects.Delete


'resim yolunun bulunması

Dim resimyolu1 As Variant
Dim teklifyolu As Variant

Dim resim1 As Object

Dim teklif As Object

a = 6
b = 8
For i = 1 To 10
resimyolu1 = ActiveWorkbook.Path & "\Resimler\" & [C3] & " (" & i & ").jpg"



'resmi oluştur
Set resim1 = ActiveSheet.Pictures.Insert(resimyolu1)

With Range("G" & a & ":g" & b)
resim1.Top = .Top
resim1.Left = .Left
resim1.Height = 100
resim1.Width = 100
End With

With Range("h " & a & ":H" & b)
resim2.Top = .Top
resim2.Left = .Left
resim2.Height = 100
resim2.Width = 100
End With
a = a + 3
b = b + 3

Next
teklifyolu = ActiveWorkbook.Path & "\" & "Resimler" & "\" & [C3] & "teklif" & ".jpg"
Set teklif = ActiveSheet.Pictures.Insert(teklifyolu)

'resmi boyutlandır



With Range("k6:q20")
teklif.Top = .Top
teklif.Left = .Left
teklif.Height = 210
teklif.Width = 250
End With

End Sub
Genişletmek için tıkla ...

With Range("h " & a & ":H" & b)
resim2.Top = .Top
resim2.Left = .Left
resim2.Height = 100
resim2.Width = 100
End With
a = a + 3
b = b + 3

burada hata veriyor.

Korhan Ayhan;

Korhan Ayhan' Alıntı:
DIR komutu ile resim var mı kontrol edilir, sonrasında resim varsa eklenir ve boyutlandırılır. Bütün resimler için aynı döngüyü uygulayın.

Kod: 
If Dir(Resimyolu1) <> "" Then
Set resim1 = ActiveSheet.Pictures.Insert(resimyolu1)
With Range("G6:g8")
resim1.Top = .Top
resim1.Left = .Left
resim1.Height = 100
resim1.Width = 100
End With
Genişletmek için tıkla ...

bu kodu yazıyorum makro hiç başlamıyor en başta hata veriyor.
 
Son düzenleme:
Korhan bey "End if" hatası veriyormuş if'lerin hepsini kapattım formül çalıştı teşekkür ediyorum.
 
Hocam bu sayfaya GELİŞTİRİCİ>FORM DENETİMLERİ'nden onay düğmesi koyuyorum sayfayı kilitliyorum C3'ü değiştiriyorum resimler değişiyor ama onay kutusu gidiyor. Gitmemesi için ne yapmam lazım?

Yardımcı olursanız sevinirim...
 
Aşağıdaki komutu silip deneyin.

Kod: 
ActiveSheet.DrawingObjects.Delete

Bu kod sayfadaki tüm nesneleri siler.
 
Korhan Ayhan' Alıntı:
Aşağıdaki komutu silip deneyin.

Kod: 
ActiveSheet.DrawingObjects.Delete

Bu kod sayfadaki tüm nesneleri siler.
Genişletmek için tıkla ...

Hocam dediğinizi yaptım oldu.

Fakat bu sefer [C3]'e yanlış bir şey yazıldığında o resimleri silmiyor olan resmin üstüne bir daha resim getiriyor.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst