Hücreye açıklamanın gelmesi

[hatirlabeni]

Merhabalar.
Ekteki dosyada Tablo1 de A2 A6 hücresine veriler ve bu hücrelerde verilerin açıklaması bulunuyor.
Tablo2'de C6 hücresine veri doğrulama ile bu verileri listeledim. Yapmak istediği listelediğim bu verileri seçtiğimde tablo1 deki ilgili hücredeki açıklamanında o hücre üzerinde durduğumda göstermesini sağlamak.

 

[askm]

Tablo2 kod bölümüne aşağıdaki kodları ekleyip deneyin.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range, S1 As Worksheet
Set S1 = Sheets("Tablo1")
Application.EnableEvents = False
If Intersect(Target, [C6]) Is Nothing Then Exit Sub
If Target = "" Then Target.ClearContents
    Set c = S1.[A:A].Find(Target, LookIn:=xlValues)
    If Not c Is Nothing Then
        S1.Range("A" & c.Row).Copy Target
    End If
Set S1 = Nothing
Application.EnableEvents = True
End Sub

 

[hatirlabeni]

Sayın askm elinize sağlık mükemmel oldu buna ilave olarak yine tablo1 de b2 b100 arasındaki verilerin aynı şekilde tablo2 de D6 hücresi için nasıl kullanabilirim bunun gibi 4 farklı yerden veri listeleyeceğim.Kodu aynı şekilde alta yapıştırdım sonuç alamadım.

 

[askm]

Örnek dosyanızı eklerseniz bakalım. Alta yapıştırma ile çalışmaz.

 

[hatirlabeni]

Sayın Askm

İlgili Dosyayı Tekrardan yükledim.

İlgilinize de ayrıca Teşekkür ederim.

 

[askm]

D6 da veri doğrulama yok. C6 dan veri çekince D ve E değerleri gelsin mi istiyorsunuz. Yoksa oralarda da veri doğrulama ile seçim mi yapacaksınız.

 

[hatirlabeni]

Hocam yanlış dosyayı yüklemişim yeni dosyayı tekrardan yükleidm.

 

[askm]

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range, S1 As Worksheet
Set S1 = Sheets("Tablo1")
Application.EnableEvents = False
If Not Intersect(Target, [C6]) Is Nothing Then
    If Target = "" Then Target.ClearContents
        Set c = S1.[A:A].Find(Target, LookIn:=xlValues)
        If Not c Is Nothing Then
            S1.Range("A" & c.Row).Copy Target
        End If
End If

If Not Intersect(Target, [D6]) Is Nothing Then
    If Target = "" Then Target.ClearContents
        Set d = S1.[B:B].Find(Target, LookIn:=xlValues)
        If Not d Is Nothing Then
            S1.Range("B" & d.Row).Copy Target
        End If
End If

If Intersect(Target, [E6]) Is Nothing Then Exit Sub
    If Target = "" Then Target.ClearContents
        Set c = S1.[C:C].Find(Target, LookIn:=xlValues)
        If Not c Is Nothing Then
            S1.Range("C" & c.Row).Copy Target
        End If
        
    
Set S1 = Nothing
Application.EnableEvents = True
End Sub

 

[hatirlabeni]

Hocam teşekkür ederim elinize sağlık. Sonuç tamda istediğim gibi oldu.

İyi günler.

 

[askm]

Rica ederim. İyi günler.