Seçime göre resim getirme

[Büşra Güzelyurt]

Merhaba,

Geçenlerde buna benzer konu açmıştım ama şimdi gene problemim var.Ben her satr için ayrı ayrı resim çıksın istiyorum.

MÖncede yazılan kodda burda bir türlü uyarlayamadım. yardımcı olursanız çok menuın olurum.

,şimdiden teşekkürler...


Önceki kod :

Private Sub Worksheet_Change(ByVal Target As Range)
Application.DisplayAlerts = False
If Intersect(Target, Range("c3:c" & [c65536].End(3).Row)) Is Nothing Then Exit Sub
On Error Resume Next
Application.EnableEvents = False
    ActiveSheet.Shapes.SelectAll
    Selection.Delete
Application.EnableEvents = True
    For Each hcr In Range("c3:c" & [c65536].End(3).Row)
        Sayfa3.Shapes(hcr.Text).Copy
        Cells(hcr.Row, "b").Select
        ActiveSheet.Paste
        hcr.Select
    Next
Application.DisplayAlerts = True
End Sub

 

[usubaykan]

Merhaba;

Mevcut kodunuzu bu şekilde yeniden düzenledim umarım istediğiniz gibi olmuştur.

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.CommandBars("Picture").Visible = False
If Intersect(Target, Range("C11:C" & [C65536].End(3).Row)) Is Nothing Then Exit Sub
On Error Resume Next
    If Cells(Target.Row, "C") <> "" Then
        Resim = Left(Cells(Target.Row, "C"), 1) & " Resmi"
        Sheets("Resim").Select
        ActiveSheet.Shapes("" & Resim & "").Select
    With Selection
        .ShapeRange.LockAspectRatio = msoTrue
        .ShapeRange.Height = 42.75
        .ShapeRange.Width = 59.25
        .ShapeRange.Rotation = 0#
        .ShapeRange.LockAspectRatio = msoTrue
        .ShapeRange.Height = 27.75
        .ShapeRange.Width = 37.5
        .ShapeRange.Rotation = 0#
            
            Sheets("Resim").Shapes("" & Resim & "").Copy
            Sheets("Veri Girişi").Select
            Cells(Target.Row, "B").Select
            Paste
            Cells(Target.Row, "C").Select
        
        Sheets("Resim").Select
        .ShapeRange.LockAspectRatio = msoTrue
        .ShapeRange.Height = 42.75
        .ShapeRange.Width = 59.25
        .ShapeRange.Rotation = 0#
        Sheets("Veri Girişi").Select
    End With
    End If
Application.ScreenUpdating = True
End Sub

 

[karakaçan]

syın usubaykan ben de bu konu ile ilgilendiğim için soruyorum. cevaplarsanız sevinirim. bu yazdığınız kodu nereye yapıştıracağım

 

[usubaykan]

"Private Sub Worksheet_Change(ByVal Target As Range)" bölümü.
Yani kodu çalıştırmak istediğiniz sayfanın kod bölümüne yapıştırmalısınız. Syn Büşra Güzelyurt'un dosyasında Resim ve Veri Girişi adında 2 sayfa var.
Kodu veri girişinde çalıştırmak istediği için kod Veri Girişi sayfasının kod bölümüne yazılmaktadır.

Çalışma prensibi Target yani hedef Range yani Hücre
Belirli hücreler aralığında değişiklik yapıldığı zaman (Hedef değişikliği) makro çalışsın.

Ama bu kodu dosyanıza uyarlamanız gerekli. Buradaki resimler Ad tanımlı ve yazılan kodlar buradaki sayflarla doğrudan bağlantılı. O yüzden buradaki kodu kendi sayfanız için uygulamanız gerekli.

 

[Büşra Güzelyurt]

Çok teşekkürler fakat şöyle sorun var. Mesela 1. satırda a tipi seçtim peşine aynı satrıda b tipini seçersem bu sefer iki resim üst üste biniyor . Benmi yanlış yapıyorum acaba ?

 

[usubaykan]

Hayır siz doğru olanı yapıyorsunuz Ben resimleri sildirmemişim

 

[usubaykan]

Merhaba;

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.CommandBars("Picture").Visible = False
If Intersect(Target, Range("C11:C" & [c65536].End(3).Row)) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.CommandBars("Picture").Visible = False
 ActiveSheet.DrawingObjects.Delete
For U = 11 To Range("C65536").End(3).Row
    If Cells(U, "C") <> "" Then
        Resim = Left(Cells(U, "C"), 1) & " Resmi"
        Sheets("Resim").Select
        ActiveSheet.Shapes("" & Resim & "").Select
    With Selection
        .ShapeRange.LockAspectRatio = msoTrue
        .ShapeRange.Height = 42.75
        .ShapeRange.Width = 59.25
        .ShapeRange.Rotation = 0#
        .ShapeRange.LockAspectRatio = msoTrue
        .ShapeRange.Height = 27.75
        .ShapeRange.Width = 37.5
        .ShapeRange.Rotation = 0#
            
            Sheets("Resim").Shapes("" & Resim & "").Copy
            Sheets("Veri Girişi").Select
            Cells(U, "B").Select
            ActiveSheet.Paste
        
        Sheets("Resim").Select
        .ShapeRange.LockAspectRatio = msoTrue
        .ShapeRange.Height = 42.75
        .ShapeRange.Width = 59.25
        .ShapeRange.Rotation = 0#
        Sheets("Veri Girişi").Select
    End With
    End If
Next
Cells(Target.Row, "C").Select
Application.ScreenUpdating = True
End Sub

şeklinde deneyin.

 

[Büşra Güzelyurt]

bu sefer oldu , çok teşekkürlerrrrrrrrrrrrr ))))

 

[usubaykan]

bu sefer oldu , çok teşekkürlerrrrrrrrrrrrr ))))

Rica ederim

 

[Büşra Güzelyurt]

Başka yerdeki hücreyi boyayabilmem mümkün mü aynı sayfada ?

Merhaba,

projemde kodlar çalışıyor ve seçime göre sistem şeklilleri geliyor fakat ben başka bir aralıkta resim getirmek yada kolaysa boyamak istiyorum. Ne yapmam lazım bu kodun neresine ne eklmem lazım acaba ?

yardımınız için şimdiden teşekkürler....

 

[uyrdkl]

teşekkürler benimde işime yarayacak