Cümle içinde kelime arama

K

kgdsa

Katılım
6 Şubat 2022
Mesajlar
36
Excel Vers. ve Dili
Standart 2016
Altın Üyelik Bitiş Tarihi
06-02-2023
Merhaba,

Excel de herhangi bir hücrede bulunan kelimenin başka bir sütun halindeki cümleler içinde olup olmadığını görmek istiyorum.
Örnek;

B1 hücresine, A1 hücresinde bulunan verinin D sütunundaki cümleler içerisinde kelime bazlı olup olmadığını yazdıracağım. Eğer varsada aradığım kelimeyi yanına yazsın istiyorum

Bu konuda yardımcı olabilir misiniz.
 
E

excelokyanus500

Katılım
20 Şubat 2012
Mesajlar
242
Excel Vers. ve Dili
office2007 Türkçe
Deneyin... Sayfayı yedekledikten sonra çalıştırın.

Kod: 
Sub kelimebul()

    Dim wb As Workbook
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim rSourceHCol As Range
    Dim rSourceHCell As Range
    Dim rDestHCol As Range
    Dim rFound As Range
    Dim sFirst As String
    Dim sNotFound As String

    Set wb = ActiveWorkbook
    Set wsSource = wb.Sheets("Sayfa1")
    Set wsDest = wb.Sheets("Sayfa1")
    Set rSourceHCol = wsSource.Range("A2", wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp))
    Set rDestHCol = wsDest.Range("D2", wsDest.Cells(wsDest.Rows.Count, "D").End(xlUp))


    For Each rSourceHCell In rSourceHCol.Cells
        Set rFound = rDestHCol.Find(rSourceHCell.Value, rDestHCol.Cells(rDestHCol.Cells.Count), xlValues, xlWhole)
        If rFound Is Nothing Then
            sNotFound = sNotFound & Chr(10) & rSourceHCell.Value
        Else
            sFirst = rFound.Address
            MsgBox "Eşleşen kelime: " & rFound & Chr(10) & "Kelime hücre adresi: " & rFound.Address
        
            Do
                rFound.Offset(, -2).Value = rFound.Offset(, -2).Value & " " & rSourceHCell.Value
                Set rFound = rDestHCol.FindNext(rFound)
            Loop While rFound.Address <> sFirst
        End If
    Next rSourceHCell

    If Len(sNotFound) = 0 Then
        MsgBox "Tüm kelime işlemleriniz tamam."
    Else
        MsgBox "Aşağıdaki kelimeler bulunamadı:" & sNotFound
    End If

End Sub
 
K

kgdsa

Katılım
6 Şubat 2022
Mesajlar
36
Excel Vers. ve Dili
Standart 2016
Altın Üyelik Bitiş Tarihi
06-02-2023
excelokyanus500' Alıntı:
Deneyin... Sayfayı yedekledikten sonra çalıştırın.

Kod: 
Sub kelimebul()

    Dim wb As Workbook
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim rSourceHCol As Range
    Dim rSourceHCell As Range
    Dim rDestHCol As Range
    Dim rFound As Range
    Dim sFirst As String
    Dim sNotFound As String

    Set wb = ActiveWorkbook
    Set wsSource = wb.Sheets("Sayfa1")
    Set wsDest = wb.Sheets("Sayfa1")
    Set rSourceHCol = wsSource.Range("A2", wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp))
    Set rDestHCol = wsDest.Range("D2", wsDest.Cells(wsDest.Rows.Count, "D").End(xlUp))


    For Each rSourceHCell In rSourceHCol.Cells
        Set rFound = rDestHCol.Find(rSourceHCell.Value, rDestHCol.Cells(rDestHCol.Cells.Count), xlValues, xlWhole)
        If rFound Is Nothing Then
            sNotFound = sNotFound & Chr(10) & rSourceHCell.Value
        Else
            sFirst = rFound.Address
            MsgBox "Eşleşen kelime: " & rFound & Chr(10) & "Kelime hücre adresi: " & rFound.Address
       
            Do
                rFound.Offset(, -2).Value = rFound.Offset(, -2).Value & " " & rSourceHCell.Value
                Set rFound = rDestHCol.FindNext(rFound)
            Loop While rFound.Address <> sFirst
        End If
    Next rSourceHCell

    If Len(sNotFound) = 0 Then
        MsgBox "Tüm kelime işlemleriniz tamam."
    Else
        MsgBox "Aşağıdaki kelimeler bulunamadı:" & sNotFound
    End If

End Sub
Genişletmek için tıkla ...
Merhaba,

Bulunamadı diyor ama kontrol eder misiniz ?
 
E

excelokyanus500

Katılım
20 Şubat 2012
Mesajlar
242
Excel Vers. ve Dili
office2007 Türkçe
Merhaba,

Yukarıdaki kod A2'den itibaren kelimeleri(A sütununda bulunan her satırı) D sütununda arar ve varsa B sütununa giderek kelimeyi yazar. Ancak satır satır eşleştirmez. Örnek dosya olmadığı için genel bir program olarak düzenlenmiştir. Açıklama şuan bana yetersiz geliyor. Dolayısıyla genel bir işlem yapıldı.
Alternatif...
Kod: 
Sub KelimeBul()
Dim Wb As Workbook
Dim ws As Worksheet
Dim rng1 As Range
Set Wb = ThisWorkbook
Set ws = Wb.Sheets("Sayfa1")
Set rng1 = ws.Range("D:D").Find(What:=ws.[a1], LookIn:=xlValues)
If Not rng1 Is Nothing Then
Range("B1").Value = Range("B1").Value & " " & rng1 & " " & " -Yeri " & rng1.Address
Else
MsgBox "Kelime bulunamadı", vbCritical
End If
End Sub
 
K

kgdsa

Katılım
6 Şubat 2022
Mesajlar
36
Excel Vers. ve Dili
Standart 2016
Altın Üyelik Bitiş Tarihi
06-02-2023
excelokyanus500' Alıntı:
Merhaba,

Yukarıdaki kod A2'den itibaren kelimeleri(A sütununda bulunan her satırı) D sütununda arar ve varsa B sütununa giderek kelimeyi yazar. Ancak satır satır eşleştirmez. Örnek dosya olmadığı için genel bir program olarak düzenlenmiştir. Açıklama şuan bana yetersiz geliyor. Dolayısıyla genel bir işlem yapıldı.
Alternatif...
Kod: 
Sub KelimeBul()
Dim Wb As Workbook
Dim ws As Worksheet
Dim rng1 As Range
Set Wb = ThisWorkbook
Set ws = Wb.Sheets("Sayfa1")
Set rng1 = ws.Range("D:D").Find(What:=ws.[a1], LookIn:=xlValues)
If Not rng1 Is Nothing Then
Range("B1").Value = Range("B1").Value & " " & rng1 & " " & " -Yeri " & rng1.Address
Else
MsgBox "Kelime bulunamadı", vbCritical
End If
End Sub
Genişletmek için tıkla ...
A sutününda anahtar kelimeler var ve D Sutününda cümleler içeriyor, A sutünüdaki anahtar kelimeler D sutünunda cümlelerden içeriyorsa B Sutünuna yazmasını istiyorum aslında
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,269
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Örnek dosya paylaşabilir misiniz?

Dosya içinde görmek istediğiniz sonucu da belirtirseniz yardım almanız kolaylaşır.
 
E

excelokyanus500

Katılım
20 Şubat 2012
Mesajlar
242
Excel Vers. ve Dili
office2007 Türkçe
Deneyin...Modifiye edilmiştir..

Kod: 
Sub Karşılaştır()
   
    Dim Ws As Worksheet
    Dim Rng As Range
    Dim Fnd As Range
    Dim Rl As Long
    Dim R As Long

    Set Ws = ActiveSheet
    Application.ScreenUpdating = False
    With Ws
        
        Rl = .Cells(.Rows.Count, "D").End(xlUp).Row ' En uzun sütun D kabul edilmiştir. Yanlış ise A yapın.
    
        Set Rng = Range(.Cells(2, 4), .Cells(Rl, 4))
        For R = 1 To Rl
            If XlFind(Fnd, Rng, .Cells(R, 1).value, LookAt:=xlPart) Then
                .Cells(R, "B").value = Fnd & Chr(10) & "Yeri:" & Fnd.Address
            End If
        Next R
    End With
    Application.ScreenUpdating = True
End Sub

Function XlFind(Fnd As Range, _
                Where As Range, _
                ByVal What As Variant, _
                Optional ByVal LookIn As Variant = xlValues, _
                Optional ByVal LookAt As Long = xlWhole, _
                Optional ByVal SearchBy As Long = xlByColumns, _
                Optional ByVal StartAfter As Long, _
                Optional ByVal Direction As Long = xlNext, _
                Optional ByVal MatchCase As Boolean = False, _
                Optional ByVal MatchByte As Boolean = False, _
                Optional ByVal MatchPosition As Long, _
                Optional ByVal After As Range, _
                Optional ByVal FindFormat As Boolean = False) As Boolean
   

    Dim Search As Range
    Dim FirstFnd As Range

    Set Search = Where
    With Search
        If After Is Nothing Then
            If StartAfter Then
                StartAfter = WorksheetFunction.Min(StartAfter, .Cells.Count)
            Else
                StartAfter = .Cells.Count
            End If
            Set After = .Cells(StartAfter)
        End If

        If MatchPosition > 1 Then LookAt = xlPart
        Set Fnd = .Find(What:=What, After:=After, _
                        LookIn:=LookIn, LookAt:=LookAt, _
                        SearchOrder:=SearchBy, SearchDirection:=Direction, _
                        MatchCase:=MatchCase, MatchByte:=MatchByte, _
                        SearchFormat:=FindFormat)
        If Not Fnd Is Nothing Then
            Set FirstFnd = Fnd
            Do
                If MatchPosition Then
                    If InStr(1, Fnd.value, What, vbTextCompare) = MatchPosition Then
                        Exit Do
                    Else
                        Set Fnd = .FindNext(Fnd)
                    End If
                Else
                    Exit Do
                End If
            Loop While Not (Fnd Is Nothing) And Not (Fnd Is FirstFnd)
        End If
    End With

    XlFind = Not (Fnd Is Nothing)
End Function
 
K

kgdsa

Katılım
6 Şubat 2022
Mesajlar
36
Excel Vers. ve Dili
Standart 2016
Altın Üyelik Bitiş Tarihi
06-02-2023
excelokyanus500' Alıntı:
Deneyin...Modifiye edilmiştir..

Kod: 
Sub Karşılaştır()
  
    Dim Ws As Worksheet
    Dim Rng As Range
    Dim Fnd As Range
    Dim Rl As Long
    Dim R As Long

    Set Ws = ActiveSheet
    Application.ScreenUpdating = False
    With Ws
       
        Rl = .Cells(.Rows.Count, "D").End(xlUp).Row ' En uzun sütun D kabul edilmiştir. Yanlış ise A yapın.
   
        Set Rng = Range(.Cells(2, 4), .Cells(Rl, 4))
        For R = 1 To Rl
            If XlFind(Fnd, Rng, .Cells(R, 1).value, LookAt:=xlPart) Then
                .Cells(R, "B").value = Fnd & Chr(10) & "Yeri:" & Fnd.Address
            End If
        Next R
    End With
    Application.ScreenUpdating = True
End Sub

Function XlFind(Fnd As Range, _
                Where As Range, _
                ByVal What As Variant, _
                Optional ByVal LookIn As Variant = xlValues, _
                Optional ByVal LookAt As Long = xlWhole, _
                Optional ByVal SearchBy As Long = xlByColumns, _
                Optional ByVal StartAfter As Long, _
                Optional ByVal Direction As Long = xlNext, _
                Optional ByVal MatchCase As Boolean = False, _
                Optional ByVal MatchByte As Boolean = False, _
                Optional ByVal MatchPosition As Long, _
                Optional ByVal After As Range, _
                Optional ByVal FindFormat As Boolean = False) As Boolean
  

    Dim Search As Range
    Dim FirstFnd As Range

    Set Search = Where
    With Search
        If After Is Nothing Then
            If StartAfter Then
                StartAfter = WorksheetFunction.Min(StartAfter, .Cells.Count)
            Else
                StartAfter = .Cells.Count
            End If
            Set After = .Cells(StartAfter)
        End If

        If MatchPosition > 1 Then LookAt = xlPart
        Set Fnd = .Find(What:=What, After:=After, _
                        LookIn:=LookIn, LookAt:=LookAt, _
                        SearchOrder:=SearchBy, SearchDirection:=Direction, _
                        MatchCase:=MatchCase, MatchByte:=MatchByte, _
                        SearchFormat:=FindFormat)
        If Not Fnd Is Nothing Then
            Set FirstFnd = Fnd
            Do
                If MatchPosition Then
                    If InStr(1, Fnd.value, What, vbTextCompare) = MatchPosition Then
                        Exit Do
                    Else
                        Set Fnd = .FindNext(Fnd)
                    End If
                Else
                    Exit Do
                End If
            Loop While Not (Fnd Is Nothing) And Not (Fnd Is FirstFnd)
        End If
    End With

    XlFind = Not (Fnd Is Nothing)
End Function
Genişletmek için tıkla ...
Merhaba Teşekkür ederim,

Şöyle bir şey daha olur mu acaba ? A sutünunda Anahtar kelime var , D sutünunda cümle var eğer cümlenin içinde Anahtar kelime varsa E Sutününa Anahtar kelimesini yazsın
 
E

excelokyanus500

Katılım
20 Şubat 2012
Mesajlar
242
Excel Vers. ve Dili
office2007 Türkçe
Merhaba. Korhan Bey'in belirttiği üzere dosya eklenmesi sorunun çözümünde çok fayda sağlayacaktır.
Yenilenmiş kod aşağıdadır. Deneyiniz.

Kod: 
Sub Karşılaştır()
  
    Dim ws As Worksheet
    Dim Rng As Range
    Dim Fnd As Range
    Dim Rl As Long
    Dim R As Long

    Set ws = ActiveSheet
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.Hyperlinks.Delete
    With ws
       
        Rl = .Cells(.Rows.Count, "D").End(xlUp).Row ' En uzun sütun D kabul edilmiştir. Yanlış ise A yapın.
   
        Set Rng = Range(.Cells(2, 4), .Cells(Rl, 4))
        For R = 1 To Rl
            If XlFind(Fnd, Rng, .Cells(R, 1).Value, LookAt:=xlPart) Then
                .Cells(R, "B").Value = Fnd & Chr(10) & "Yeri:" & Fnd.Address
                yer = Right(Fnd.Address, 1)
                .Cells(yer, "E").Value = Cells(R, 1).Value
              ActiveSheet.Hyperlinks.Add Cells(R, 1), Address:="", SubAddress:="'" & ActiveSheet.Name & "'!D" & yer ' Hyperlink eklendi
            End If
        Next R
    End With
    Application.ScreenUpdating = True
End Sub






Function XlFind(Fnd As Range, _
                Where As Range, _
                ByVal What As Variant, _
                Optional ByVal LookIn As Variant = xlValues, _
                Optional ByVal LookAt As Long = xlWhole, _
                Optional ByVal SearchBy As Long = xlByColumns, _
                Optional ByVal StartAfter As Long, _
                Optional ByVal Direction As Long = xlNext, _
                Optional ByVal MatchCase As Boolean = False, _
                Optional ByVal MatchByte As Boolean = False, _
                Optional ByVal MatchPosition As Long, _
                Optional ByVal After As Range, _
                Optional ByVal FindFormat As Boolean = False) As Boolean
  

    Dim Search As Range
    Dim FirstFnd As Range

    Set Search = Where
    With Search
        If After Is Nothing Then
            If StartAfter Then
                StartAfter = WorksheetFunction.Min(StartAfter, .Cells.Count)
            Else
                StartAfter = .Cells.Count
            End If
            Set After = .Cells(StartAfter)
        End If

        If MatchPosition > 1 Then LookAt = xlPart
        Set Fnd = .Find(What:=What, After:=After, _
                        LookIn:=LookIn, LookAt:=LookAt, _
                        SearchOrder:=SearchBy, SearchDirection:=Direction, _
                        MatchCase:=MatchCase, MatchByte:=MatchByte, _
                        SearchFormat:=FindFormat)
        If Not Fnd Is Nothing Then
            Set FirstFnd = Fnd
            Do
                If MatchPosition Then
                    If InStr(1, Fnd.Value, What, vbTextCompare) = MatchPosition Then
                        Exit Do
                    Else
                        Set Fnd = .FindNext(Fnd)
                    End If
                Else
                    Exit Do
                End If
            Loop While Not (Fnd Is Nothing) And Not (Fnd Is FirstFnd)
        End If
    End With

    XlFind = Not (Fnd Is Nothing)
End Function
 
K

kgdsa

Katılım
6 Şubat 2022
Mesajlar
36
Excel Vers. ve Dili
Standart 2016
Altın Üyelik Bitiş Tarihi
06-02-2023
excelokyanus500' Alıntı:
Merhaba. Korhan Bey'in belirttiği üzere dosya eklenmesi sorunun çözümünde çok fayda sağlayacaktır.
Yenilenmiş kod aşağıdadır. Deneyiniz.

Kod: 
Sub Karşılaştır()
 
    Dim ws As Worksheet
    Dim Rng As Range
    Dim Fnd As Range
    Dim Rl As Long
    Dim R As Long

    Set ws = ActiveSheet
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.Hyperlinks.Delete
    With ws
      
        Rl = .Cells(.Rows.Count, "D").End(xlUp).Row ' En uzun sütun D kabul edilmiştir. Yanlış ise A yapın.
  
        Set Rng = Range(.Cells(2, 4), .Cells(Rl, 4))
        For R = 1 To Rl
            If XlFind(Fnd, Rng, .Cells(R, 1).Value, LookAt:=xlPart) Then
                .Cells(R, "B").Value = Fnd & Chr(10) & "Yeri:" & Fnd.Address
                yer = Right(Fnd.Address, 1)
                .Cells(yer, "E").Value = Cells(R, 1).Value
              ActiveSheet.Hyperlinks.Add Cells(R, 1), Address:="", SubAddress:="'" & ActiveSheet.Name & "'!D" & yer ' Hyperlink eklendi
            End If
        Next R
    End With
    Application.ScreenUpdating = True
End Sub






Function XlFind(Fnd As Range, _
                Where As Range, _
                ByVal What As Variant, _
                Optional ByVal LookIn As Variant = xlValues, _
                Optional ByVal LookAt As Long = xlWhole, _
                Optional ByVal SearchBy As Long = xlByColumns, _
                Optional ByVal StartAfter As Long, _
                Optional ByVal Direction As Long = xlNext, _
                Optional ByVal MatchCase As Boolean = False, _
                Optional ByVal MatchByte As Boolean = False, _
                Optional ByVal MatchPosition As Long, _
                Optional ByVal After As Range, _
                Optional ByVal FindFormat As Boolean = False) As Boolean
 

    Dim Search As Range
    Dim FirstFnd As Range

    Set Search = Where
    With Search
        If After Is Nothing Then
            If StartAfter Then
                StartAfter = WorksheetFunction.Min(StartAfter, .Cells.Count)
            Else
                StartAfter = .Cells.Count
            End If
            Set After = .Cells(StartAfter)
        End If

        If MatchPosition > 1 Then LookAt = xlPart
        Set Fnd = .Find(What:=What, After:=After, _
                        LookIn:=LookIn, LookAt:=LookAt, _
                        SearchOrder:=SearchBy, SearchDirection:=Direction, _
                        MatchCase:=MatchCase, MatchByte:=MatchByte, _
                        SearchFormat:=FindFormat)
        If Not Fnd Is Nothing Then
            Set FirstFnd = Fnd
            Do
                If MatchPosition Then
                    If InStr(1, Fnd.Value, What, vbTextCompare) = MatchPosition Then
                        Exit Do
                    Else
                        Set Fnd = .FindNext(Fnd)
                    End If
                Else
                    Exit Do
                End If
            Loop While Not (Fnd Is Nothing) And Not (Fnd Is FirstFnd)
        End If
    End With

    XlFind = Not (Fnd Is Nothing)
End Function
Genişletmek için tıkla ...
Çok teşekkür ederim. İstediğim gibi oldu.
 
K

kgdsa

Katılım
6 Şubat 2022
Mesajlar
36
Excel Vers. ve Dili
Standart 2016
Altın Üyelik Bitiş Tarihi
06-02-2023
Haklısınız Korhan bey, Altın üye olmadığım için yükleyemiyorum.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,269
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Altın üye olmayan üyelerimiz harici dosya barındırma sitelerini kullanarak örnek dosya paylaşımında bulunabiliyor.
 
B

bmutlu966

Altın Üye
Katılım
26 Ocak 2006
Mesajlar
756
Excel Vers. ve Dili
Office 365 İngilizce 64 Bit
Altın Üyelik Bitiş Tarihi
31-01-2025
Deneyiniz.

Kod: 
Sub kelime_bul()

kelime = [A1]
cumle = [D1]

If InStr(1, cumle, kelime, vbBinaryCompare) > 0 Then
    [E1] = kelime
Else
    [E1] = "Yok"
End If

End Sub
 
K

kgdsa

Katılım
6 Şubat 2022
Mesajlar
36
Excel Vers. ve Dili
Standart 2016
Altın Üyelik Bitiş Tarihi
06-02-2023
bmutlu966' Alıntı:
Deneyiniz.

Kod: 
Sub kelime_bul()

kelime = [A1]
cumle = [D1]

If InStr(1, cumle, kelime, vbBinaryCompare) > 0 Then
    [E1] = kelime
Else
    [E1] = "Yok"
End If

End Sub
Genişletmek için tıkla ...
Merhaba,

Cümle içinde yok olarak gösteriyor, A ve D sutünunda Ahmet olursa buluyor.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst