Veri Doğrulamada Resim Gösterimi

[Büşra Güzelyurt]

Veri Doğrulamada Resim Gösterimi KOD Yardımı

Merhaba,

Bu konuyu aslında ben düzenledim tekrardan... Hamit bey sağolsun yardımcı olduda bir yerde takıldım...

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [c3:c4]) Is Nothing Then Exit Sub
    If Target.Text = "Ekle" Then
        Shapes("2 Resim").Visible = msoFalse
        Shapes("1 Resim").Visible = msoTrue
        Shapes("1 Resim").Top = Target.Offset(0, -1).Top
        Shapes("1 Resim").Left = Target.Offset(0, -1).Left
    ElseIf Target.Text = "Sil" Then
        Shapes("1 Resim").Visible = msoFalse
        Shapes("2 Resim").Visible = msoTrue
        Shapes("2 Resim").Top = Target.Offset(0, -1).Top
        Shapes("2 Resim").Left = Target.Offset(0, -1).Left
    End If
End Sub

Bu şekilde kodları yazdım fakat A ürünü için ekleyi seçtim diyelim alt satıra geçip B ürünü için sil i seçtiğimde A daki resim kayboluyor.

Bunu nasıl düzeltebilirim bu kod düzeninde, lütfen acil yardım

 

[hamitcan]

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [c3:c4]) Is Nothing Then Exit Sub
    If Target.Text = "Ekle" Then
        Shapes("2 Resim").Visible = msoFalse
        Shapes("1 Resim").Visible = msoTrue
        Shapes("1 Resim").Top = Target.Offset(0, -1).Top
        Shapes("1 Resim").Left = Target.Offset(0, -1).Left
    ElseIf Target.Text = "Sil" Then
        Shapes("1 Resim").Visible = msoFalse
        Shapes("2 Resim").Visible = msoTrue
        Shapes("2 Resim").Top = Target.Offset(0, -1).Top
        Shapes("2 Resim").Left = Target.Offset(0, -1).Left
    End If
End Sub

 

[Büşra Güzelyurt]

Hamit bey, çok teşekkür ederim fakat şöyle bir sorun var, A ürünü için Ekleyi seçtim diyelim fakat B ürünü içinde ekle yada sil seçtiğim anda A daki simge kayboluyor, heralde if ten dolayı... Bu naıl her satır için ayrı ayrı yapabilirim. Birde bişey sorcam , resimleri nasıl 1 resim 2 resim diye ayırdınız, çünkü ben birkaç üründe ikon yerine resim göstericemde öğrenmek için soruyorum.

 

[hamitcan]

Sub resimcagir()
    ActiveSheet.Shapes.SelectAll
    Selection.Delete
    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
End Sub

Not: Sembolleri Sayfa3 içine ekleyin.

 

[Büşra Güzelyurt]

Hepsini sayfa bire aynen şu şekilde yapıştırdım, resimleride 3.sayfaya b solonuna yerleştridim ama olmadı ben yapamadım sanırım,

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [c3:c4]) Is Nothing Then Exit Sub
If Target.Text = "Ekle" Then
Shapes("2 Resim").Visible = msoFalse
Shapes("1 Resim").Visible = msoTrue
Shapes("1 Resim").Top = Target.Offset(0, -1).Top
Shapes("1 Resim").Left = Target.Offset(0, -1).Left
ElseIf Target.Text = "Sil" Then
Shapes("1 Resim").Visible = msoFalse
Shapes("2 Resim").Visible = msoTrue
Shapes("2 Resim").Top = Target.Offset(0, -1).Top
Shapes("2 Resim").Left = Target.Offset(0, -1).Left
End If
End Sub

Sub resimcagir()
ActiveSheet.Shapes.SelectAll
Selection.Delete
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
End Sub

Nerde yanlış yapıyorum anlamadım

 

[Büşra Güzelyurt]

yokmu fikir sunabilecek, lütfen acil

 

[hamitcan]

Dün biraz acelem vardı, cevap eksik oldu. Şimdi eklediğim dosyayı inceleyin, işinizi görmesi lazım.

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

 

[Büşra Güzelyurt]

çok teşekkürler hamit bey, Allah razı olsun sizden... çok işime yarayacak bu formül... tekrardan teşekkürler