2 ayrı sayfada aynı olan değerleri bulma

[sadi_52]

değerli form uzmanları konu başlığını yanlış kullanmış olabilirim size şöyle anlatayım çalışma kitabımın ICD_10 sayfasın A sütununda devletin belirlemiş olduğu otuz yedi bini aşkın hastalık kodunu listeledim B sütununa ise bu kodların açıklamalarını yazdım benim istediğim ise aynı çalışma kitabında YATAN sayfasının J sütununa yazdığım bir kodun açıklamasını görmek için, yazdığım koda tıkladığımda ICD_10 sayfasın A sütununda bu kod hangi hücrede ise o hücreye gitmek ekte bir dosyam mevcut ilgilenen arkadaşlara teşekkür ederim

 

[Mehmet Şahin]

İyi akşamlar,
"YATAN" sayfasının kod bölümüne aşağıdaki kodları yapıştırınız. "J" sütunundaki değer hücrelerini çift tıklayarak sonucu test ediniz. Kolay gelsin.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("j2:j" & [j65536].End(3).Row)) Is Nothing Then Exit Sub
   a = Application.WorksheetFunction.Match(Target.Value, Sheets("ICD_10").Range("a:a"), 0)
     Application.Goto ActiveWorkbook.Sheets("ICD_10").Cells(a, "a")
End Sub

 

[Skorpiyon]

Sayın dentex'in kodları daha uygun ama bu da alternatif olsun,

Sub Düğme1_Tıklat()
a = ActiveCell
Sheets("ICD_10").Select
Cells.Find(What:=a).Activate
End Sub

YATAN sayfasına 1 buton koyun, kodları botuna atayın. J sütunundan veriyi seçin ve butona basın.

 

[sadi_52]

sayın dantex kodlarınız çok güzel oldu tam isteiğim gibi ayrıca şaban beyede çalışmasından dolayı teşekkür ederim. sayın dantex birde şöyle bir şey olabilirmi hücre üzerine gelince yazılı kodun açıklamasını görebilirmiyiz acaba ekte örnek dosyam mevcuttur

 

[Mehmet Şahin]

Merhaba,
sayfanın kod bölümüne ekleyiniz.
İyi çalışmalar.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("j2:j" & [j65536].End(3).Row)) Is Nothing Then Exit Sub
Dim s1 As Worksheet
Set s1 = Sheets("ICD_10")
On Error GoTo son
sat = Application.WorksheetFunction.Match(Target.Value, s1.Range("a:a"), 0)
Target.ClearComments
  If s1.Cells(sat + 1, "a") <> "" Then
    yrm = yrm & " " & s1.Cells(sat, "b") & " " & s1.Cells(sat, "c")
    Else
Do
   If s1.Cells(sat, "b") = "" And s1.Cells(sat, "c") = "" Then Exit Do
    yrm = yrm & " " & s1.Cells(sat, "b") & " " & s1.Cells(sat, "c")
sat = sat + 1
Loop While Not s1.Cells(sat, "a") <> ""
End If

Target.AddComment Text:=yrm
Target.Comment.Shape.TextFrame.AutoSize = True
son:
Set s1 = Nothing
End Sub

 

[sadi_52]

sayın dantex çalışmanız karşısında şaşkınlığım ve hayranlığım bir yana bu soruna getirdiğiniz çözümü takdir etmemek elde değil harikasınız kodlar tam istediğim gibi oldu ve çok işime yaradı teşekkür ederim

 

[Mehmet Şahin]

Sayın Sadi_52,
övgüleriniz için teşekkürler. Ancak kod hatalı ve sevmedim. Yukarıdaki mesajda kodları tekrar güncelledim. İyi çalışmalar

 

[sadi_52]

sayın dantex bu kodlarda aynen işime çok yaradı ben bir fark göremedim ama bunlarda süper çalışıyor elinize sağlık iyi akşamlar

 

[Mehmet Şahin]

Rica ederim,
sağlıcakla kalın.