Private Sub Worksheet_DeBug

[undenim]

Merhabalar;
yaptığım kodlamada sürekli Private Sub Worksheet_Change(ByVal Target As Range) hatası alıyorum.
kodlamalar doğru, sorun nereden kaynaklanabilir_?

 

[Muzaffer Ali]

Merhaba.

Aynı prosedürden bir tane daha var onun için hata alıyorsunuz.
Bir kod sayfası içinde aynı isimde iki prosedür olamaz.

Yani aşağıdaki satır kod sayfanızda bir yerde daha olmalı onu silmelisiniz.

Private Sub Worksheet_Change(ByVal Target As Range)

 

[undenim]

Merhaba;

Tüm sayfaları tek tek inceledim ancak başka kod olan bir sayfa yok.
Kullandığım kodda da bir hata görünmüyor ancak halen çözebilmiş değilim.

 

[undenim]

Yapmak istediğim, B sütununda veri doğrulama ile L sütununa değişken atamak, bu değişken adı ile D sütununa resim çağırmak.

Private Sub Worksheet_Change(ByVal Target As Range)

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

' Hata Kontrolü
On Error GoTo çıkış


' Resimleri Sil

ActiveSheet.DrawingObjects.Delete

'Resim yolu bulunması

Dim ResimYolu As Variant
Dim Resim As Object

For Satır = 1 To 2500


ResimYolu = ActiveWorkbook.Path & "\" & Range("l" & Satır) & ".jpg"


' Resmi Oluştur

Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

' Resmi Boyutlandır

With Range("d" & Satır)
Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width

End With

Next Satır


çıkış:


End Sub

 

[Muzaffer Ali]

Dosyanızı görmeden tahminde bulunmak zor. Özel değilse dosyanızı ekleyin kontrol edelim.

 

[undenim]

Dm den gönderebilir miyim?

 

[Muzaffer Ali]

Tabi gönderebilirsiniz.

 

[Muzaffer Ali]

Resim isimleri B kolonunda yazıyor değil mi? Eğer doğruysa aşağıdaki kodları kullanabilirsiniz.

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
    Dim ResimYolu As Variant
    Dim resim As Object
    Dim Satir As Integer
    If Target = "" Then Exit Sub
    Satir = Target.Row
    ' Hata Kontrolü
    'On Error GoTo çıkış
    ' Resimleri Sil
    ActiveSheet.DrawingObjects.Delete
    'Resim yolu bulunması
    ResimYolu = ActiveWorkbook.Path & "\" & Range("B" & Satir) & ".jpg"
    ' Resmi Oluştur
    
    If Dir(ResimYolu) = "" Then
        MsgBox "Resim: '" & ResimYolu & "' bulunamıyor. Dosya adını ve yolunu kontrol ediniz.", vbCritical
        Exit Sub
    End If
    Set resim = ActiveSheet.Pictures.Insert(ResimYolu)
    ' Resmi Boyutlandır
    With Range("d" & Satir + 1)
        resim.Top = .Top
        resim.Left = .Left
        resim.Height = .Height
        resim.Width = .Width
    End With
    
çıkış:

End Sub

 

[undenim]

Teşekkür ederim.

şimdi resim alabiliyorum ancak bir sonraki satıra gelip oraya resim çektiğimde daha önce çekilen resim siliniyor.

 

[Muzaffer Ali]

Aşağıdaki kodları deneyin.

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
    Dim ResimYolu As Variant
    Dim resim As Picture
    Dim Satir As Integer
    Dim ResimBak As Integer
    
    If Target = "" Then Exit Sub
    Satir = Target.Row

    If DrawingObjects.Count > 0 Then
        For ResimBak = 1 To DrawingObjects.Count
            If DrawingObjects(ResimBak).Name = Target.Text Then
                DrawingObjects(ResimBak).Delete
                Exit For
            End If
        Next
    End If
    ResimYolu = ActiveWorkbook.Path & "\" & Target.Text & ".jpg"
    
    If Dir(ResimYolu) = "" Then
        MsgBox "Resim: '" & ResimYolu & "' bulunamıyor. Dosya adını ve yolunu kontrol ediniz.", vbCritical
        Exit Sub
    End If
    Set resim = ActiveSheet.Pictures.Insert(ResimYolu)
    With Range("d" & Satir + 1)
        resim.Top = .Top
        resim.Left = .Left
        resim.Height = .Height
        resim.Width = .Width
        resim.Name = Target.Text
    End With
    
çıkış:

End Sub

 

[undenim]

Teşekkür ederim, şimdi çözüme kavuşturduk.