Kelime Bulma

[Mx@Raid]

arkadaşlar basit bir örnek dosya oluşturdum. burada 1 sayfada cümleler var, 2. sayfada ise cümle içerisinde geçen bir kelime bunun hangi satırda yer aldığını bulup karşısına yazmasını nasıl sağlarız. burada yadığım iki satırlık bir örnek ama bunun çok daha fazla hücrede bu şekilde olduğunu ve aranmasını istediğmiz kelimelerin çok olduğunu varsayacak olursak nasıl bir makro uygulayabiliriz.

 

[Necdet]

Merhaba,

Aşağıdaki kodları deneyiniz.

Sub AraBul()
Dim i As Long
Dim s1 As Worksheet
Dim s2 As Worksheet
Dim c As Range
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Select
Application.ScreenUpdating = False
Columns("B:B").ClearContents
For i = 1 To [A65536].End(3).Row
    With s1.Range("A:A")
        Set c = .Find(Cells(i, "A"), LookIn:=xlValues)
        If Not c Is Nothing Then
            Adres = c.Address
            Do
                If Cells(i, "B") = "" Then
                    Cells(i, "B") = c.Row
                Else
                    Cells(i, "B") = Cells(i, "B") & "--" & c.Row
                End If
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adres
        End If
    End With
Next i
Application.ScreenUpdating = False
MsgBox "tamamdır..."
End Sub

 

[baydeniro]

Sayın Necdet Yeşertener, paylaşım için teşekkürler.

 

[Mx@Raid]

Sayın Necdet bey güzel ama tam da benim istediğimi sağlamıyor. Şöyleki hangi satırda olduğunu bulacak ve o kelimeyi ilgili satıra yazacak.
Yardımınız için teşekkür ederim.

 

[Mx@Raid]

Sub AraBul()
Dim i As Long
Dim s1 As Worksheet
Dim s2 As Worksheet
Dim c As Range

Set s1 = Sheets("Sorulama yapılacak Dosya")
Set s2 = Sheets("Anahtar Kelimeler")
s2.Select
Application.ScreenUpdating = False
Columns("B:B").ClearContents

For i = 1 To [A65536].End(3).Row
    With s1.Range("A:A")
        Set c = .Find(Cells(i, "A"), LookIn:=xlValues)
        If Not c Is Nothing Then
            Adres = c.Address
            Do
                If Cells(i, "B") = "" Then
                    Cells(i, "B") = c.Row
                Else
                    Cells(i, "B") = Cells(i, "B") & "--" & c.Row
                End If
                Set c = .FindNext(c)
                [COLOR="Red"]c((i - i) + 1, "B") = s2.Cells(i, "a")[/COLOR]
            Loop While Not c Is Nothing And c.Address <> Adres
        End If
    End With
Next i
Application.ScreenUpdating = False
MsgBox "tamamdır..."
End Sub

Arkadaşlar Necdet beyin yazdığı koda küçük bir ekle istediğim sonucu elde ettim. Yardımları için necdet beye teşekkür ederim.

 

[Necdet]

Güle güle kullanınız.

 

[Mx@Raid]

Arkadaşlar hata çöülemedi mesajı vermiştim ancak sonunda basit bir denklemle sorun halloldu 5. mesajdaki kodda görebilirsiniz.