Hedef Kelime Arama ve Taşıma

[ta2uk]

Bir excel tablosunun içerisinde 16123 adet hedef kelimeyi aratıp, hedef kelimenin bulunduğu hücrelerin yer aldığı satırların başka bir excel tablosuna taşınmasını istiyorum. İlgilenebilecek arkadaşlara şimdiden teşekkür ederim.

 

[Mahir64]

Merhaba,

Altın üyesiniz, örnek ekler misiniz?

 

[ta2uk]

Merhaba,

Altın üyesiniz, örnek ekler misiniz?

Buyrunuz...

 

[Muzaffer Ali]

Merhaba.

Bir modüle aşağıdaki kodu kopyalayıp çalıştırın.

Sub Test()
    Dim Bak As Integer, Say As Integer
    Dim Bulunan As Range
    Dim syfAra As Worksheet, syfAranan As Worksheet, syfSonuc As Worksheet
   
    Set syfAranan = Worksheets("Hedef Kelimeler")
    Set syfAra = Worksheets("Arama Yapılacak Tablo")
    Set syfSonuc = Worksheets("İstenen Sonuç")
   
    For Bak = 1 To syfAranan.Cells(Rows.Count, "A").End(xlUp).Row
        Set Bulunan = syfAra.Range("A1:C" & syfAra.Cells(Rows.Count, "A").End(xlUp).Row).Find(syfAranan.Cells(Bak, "A"), lookat:=xlWhole)
        If Not Bulunan Is Nothing Then
            Say = syfSonuc.Cells(Rows.Count, "A").End(xlUp).Row + 1
            If syfSonuc.Cells(1, "A") = "" Then Say = 1
            syfAra.Range("A" & Bulunan.Row & ":C" & Bulunan.Row).Cut syfSonuc.Cells(Say, "A")
            syfAra.Range("A" & Bulunan.Row & ":C" & Bulunan.Row).Delete Shift:=xlUp
        End If
    Next
End Sub