Kelime Ayıracı

[angelirde]

Örnek dosya hazırladım.
İstediğim A sütununa bir kelime database'i oluşturucam.
B de karışık kelimeler olacak ve içinde A daki kelimeler aranacak. A' daki kelimelerden biri B hücresinin içinde geçtiğinde hemen o geçen kelimeyi C ye ayıracak.

Aradım fakat bulamadım buna benzer birşey. Genelde filtre olarak buldum. Ben bi yan hücreye kesişen kelimenin ayrılmasını istiyorum mümkün müdür acaba?

 

[mustafa1205]

örneği inceleyin umarım işinizi görür

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub KELİME_BUL()
    Dim HÜCRE As Range, BUL As Range
    
    Range("C2:C65536").ClearContents
    
    For Each HÜCRE In Range("A2:A" & Range("A65536").End(3).Row)
        Set BUL = Range("B:B").Find(HÜCRE.Value)
        If Not BUL Is Nothing Then
        BUL.Offset(0, 1) = HÜCRE.Value
        End If
    Next
    
    Set BUL = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[angelirde]

Çok teşekkür ederim

 

[angelirde]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub KELİME_BUL()
    Dim HÜCRE As Range, BUL As Range
    
    Range("C2:C65536").ClearContents
    
    For Each HÜCRE In Range("A2:A" & Range("A65536").End(3).Row)
        Set BUL = Range("B:B").Find(HÜCRE.Value)
        If Not BUL Is Nothing Then
        BUL.Offset(0, 1) = HÜCRE.Value
        End If
    Next
    
    Set BUL = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Merhaba,

A da bulduğu bir kelimeyi tek bir sefer ayırıyor C hücresine ,
Bunu tekrarlı bir hale getirebilir miyiz?
Yani on farklı hücrede A da arattığımız bir kelime geçiyorsa , 10 hücredede ayrılması mümkün mü?

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub KELİME_BUL()
    Dim HÜCRE As Range, BUL As Range, ADRES As String
    
    Range("C2:C65536").ClearContents
    
    For Each HÜCRE In Range("A2:A" & Range("A65536").End(3).Row)
        Set BUL = Range("B:B").Find(HÜCRE.Value)
        If Not BUL Is Nothing Then
        ADRES = BUL.Address
        Do
        BUL.Offset(0, 1) = HÜCRE.Value
        Set BUL = Range("B:B").FindNext(BUL)
        Loop While Not BUL Is Nothing And BUL.Address <> ADRES
        End If
    Next
    
    Set BUL = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub