Aynı Sayfada İki Farklı Kod

[1Al2Ver]

Merhabalar,

Sayfa2'de, Private Sub Worksheet_Change(ByVal Target As Range) ile başlayan bir kod var, bu kod ile Sayfa1'den Sayfa2'ye veri aktarıyorum,

Yapısı itibariyle Sayfa2'ye Sayfa1'den resim aktaran ve Private Sub Worksheet_Change(ByVal Target As Range) ile başlayan bir diğer kod var,

Her iki kodu Sayfa1'in kod bölümüne yazdığımda hata almaktayım,

Bu iki kodun aynı sayfada görev yapması için yeniden düzenlenmesi gerektiğini sanıyorum,

İsteğim ; Kodlar ile, Sayfa1'deki verilerin ve resimlerin, seçilen hücreye göre (Sayfa2'de B5 hücresi) Sayfa2'ye aktarılmasıdır,

Teşekkür ederim.

 

[1Al2Ver]

Merhabalar,

Sayfa2'de, Private Sub Worksheet_Change(ByVal Target As Range) ile başlayan bir kod var, bu kod ile Sayfa1'den Sayfa2'ye veri aktarıyorum,

Yapısı itibariyle Sayfa2'ye Sayfa1'den resim aktaran ve Private Sub Worksheet_Change(ByVal Target As Range) ile başlayan bir diğer kod var,

Her iki kodu Sayfa1'in kod bölümüne yazdığımda hata almaktayım,

Bu iki kodun aynı sayfada görev yapması için yeniden düzenlenmesi gerektiğini sanıyorum,

İsteğim ; Kodlar ile, Sayfa1'deki verilerin ve resimlerin, seçilen hücreye göre (Sayfa2'de B5 hücresi) Sayfa2'ye aktarılmasıdır,

Teşekkür ederim.

Merhaba,

Böyle bir uygulama yapmak mümkün mü ?

Teşekkür ederim.

 

[1Al2Ver]

Merhaba,

Ortak bir kod yok ise, farklı bir çözüm var mı ?

Teşekkür ederim.

 

[1Al2Ver]

Merhaba,

Yoğunluktan gözden kaçmış olabilir düşüncesiyle bir kez daha hatırlatmak istedim,

Teşekkür ederim.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngBul As Range
    Dim rngResimAlani As Range
    Dim oRsm As Picture
    On Error Resume Next
    
    If Target.Address <> "$B$5" Then Exit Sub
    
    Set f = Sheets("sayfa1").[b:c].Find([b5])
    
    If f Is Nothing Then
        MsgBox [b5] & " bulunamadı.", vbInformation
    Else
        [c6] = Sheets("sayfa1").Range("c" & f.Row)
        [c7] = Sheets("sayfa1").Range("d" & f.Row)
        [c8] = Sheets("sayfa1").Range("e" & f.Row)
        [c9] = Sheets("sayfa1").Range("f" & f.Row)
        [c10] = Sheets("sayfa1").Range("g" & f.Row)
        [c11] = Sheets("sayfa1").Range("h" & f.Row)
        [c12] = Sheets("sayfa1").Range("ı" & f.Row)
        [c13] = Sheets("sayfa1").Range("j" & f.Row)
        [c14] = Sheets("sayfa1").Range("k" & f.Row)
        [c15] = Sheets("sayfa1").Range("l" & f.Row)
        [c16] = Sheets("sayfa1").Range("m" & f.Row)
        [d6] = Sheets("sayfa1").Range("n" & f.Row)
        [d7] = Sheets("sayfa1").Range("o" & f.Row)
        [d8] = Sheets("sayfa1").Range("p" & f.Row)
        [d9] = Sheets("sayfa1").Range("q" & f.Row)
        [d10] = Sheets("sayfa1").Range("r" & f.Row)
        [d11] = Sheets("sayfa1").Range("s" & f.Row)
        [d12] = Sheets("sayfa1").Range("t" & f.Row)
        [d13] = Sheets("sayfa1").Range("u" & f.Row)
        [d14] = Sheets("sayfa1").Range("w" & f.Row)
        [d15] = Sheets("sayfa1").Range("x" & f.Row)
        [d16] = Sheets("sayfa1").Range("y" & f.Row)
        [d17] = Sheets("sayfa1").Range("z" & f.Row)
    
        Set rngResimAlani = Range("B7:B23")
        'B5 hücresinde yazan malzemeyi,
        'Sayfa1'in 1.sütununda ara ve
        'Bul veya bulma, bir değişkene ata
        Set rngBul = Sheets("Sayfa1").Columns(1).Find(Target, Lookat:=xlWhole)
        'Eğer bir personel bulunduysa
        If Not rngBul Is Nothing Then
        'Önce, Resmin yerleştirileceği alanda
        'herhangi bir resim varsa, onları temizle
            For Each oRsm In ActiveSheet.Pictures
            If Not Intersect(rngResimAlani, oRsm.TopLeftCell) Is Nothing Then
            oRsm.Delete
            End If
            Next
        'Sayfa1'de bulunan malzemenin
        '28 sütun sağında bulunan resim dosyası yolunu kontrol et
        'Eğer, bu dosya halen daha bu klasörde varsa
        If Len(rngBul.Offset(0, 28)) > 0 Then
        If Len(Dir(rngBul.Offset(0, 28))) > 0 Then
        'Resmi, sayfaya ekle
        Set oRsm = ActiveSheet.Pictures.Insert(rngBul.Offset(0, 28))
        'Resmi, yerleştirilecek resim alanının
        'koordinatlarına ve boyutuna ayarla
            With oRsm
            .Left = rngResimAlani.Left
            .Top = rngResimAlani.Top
            oran = .Width / .Height
            .Height = rngResimAlani.Height
            .Width = .Height * oran
            End With
        'B7 hücresini her ihtimale karşı boşalt
        Range("B7") = Empty
        'Eğer, aranılan resim bulunamıyorsa
        Else
        'B7 hücresine bir mesaj yaz
        Range("B7") = "Kayıtlı Resim Yok"
        End If
        Else
        Range("B7") = "Kayıt Yok"
        End If
        End If
        'Hafızada oluşturduğumuz alanları boşalt
        Set rngResimAlani = Nothing
        Set rngBul = Nothing
        Set oRsm = Nothing
    
    If Sheets("sayfa1").Range("b" & f.Row).Comment.Text <> "" Then
    Sheets("sayfa1").Range("c" & f.Row).Copy
    [c6].PasteSpecial Paste:=xlPasteComments
    Application.CutCopyMode = False
    End If
    
    End If
    
    Set f = Nothing
End Sub

 

[1Al2Ver]

Sayın Korhan Ayhan merhaba,

Teşekkür ederim, sorun halloldu,

Saygılarımla.

 

[tahsinanarat]

Sn. 1Al2Ver, Resmin gelmesini sağlayamadım bir türlü, dosyanın son halini ekleyebilirmisiniz.