• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

  • Forum yazılımı güncelenmiştir.

    Beklenmedik durumlar görürseniz lütfen yönetime iletin.

Cümle içinde kelime arama

K

kgdsa

Katılım
6 Şubat 2022
Mesajlar
36
Excel Vers. ve Dili
Standart 2016
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.
 
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
 
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 ?
 
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
 
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
 
Örnek dosya paylaşabilir misiniz?

Dosya içinde görmek istediğiniz sonucu da belirtirseniz yardım almanız kolaylaşır.
 
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
 
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
 
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
 
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.
 
Haklısınız Korhan bey, Altın üye olmadığım için yükleyemiyorum.
 
Altın üye olmayan üyelerimiz harici dosya barındırma sitelerini kullanarak örnek dosya paylaşımında bulunabiliyor.
 
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
 
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.
Geri
Üst