excel text mining modeli - kelime arama,bulunan kelime öbeğini başka sayfaya kaydetme

[tömbekizade]

excel text mining modeli - kelime arama,bulunan kelime öbeğini başka sayfaya kaydetme

Örnek tabloda göreceğiniz üzere her bir satırda -kelimeleri yanyana ayrı hücrelere dağıtılmış- müşteri
mesajları mevcuttur.

Amacım şu:

Bir "input box" ım olsun, ve ben bu input box'a herhangi birşey yazınca bu yazdığım kelimeyi içeren hücreyi,
o hücrenin solundaki hücreyi ve o hücrenin sağındaki hücreyi (yani toplam 3 hücreyi) gidip Sheet2'de A2 hücresine
yazsın, aynı şekilde her satırda aynı aramayı yapıp Sheet2'de A sütunun altına kaydetmeye devam etsin. (contains komutuyla yapılacağını tahmin ediyorum)

Örnek verim Sheet1'dedir, conditional format'lara takılmayın, onları kendim deneme yaparken ekledim.
Sheet 2'de ise muhtemel bir output senaryom vardır, tabi bunu manuel olarak yaptım , amacım sadece
nasıl bir çıktı elde etmek istediğimi göstermekti.

P.S. örnek çıktıda göreceğiniz " Kelimenin hangi satırda bulunduğu" alanı opsiyoneldir. Olursa çok iyi olur
ama olmazsa da hayati birşey değil.

Saygılar,

Çağdaş Kanar

 

[tömbekizade]

dosyayı 2003 formatında da ekliyorum

 

[halit3]

dosyayı 2003 formatında da ekliyorum

Bunu denermisiniz.

Sub ara_bul()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sayfa_Adı1 = "Sheet1"
Sayfa_Adı2 = "Sheet2"
Worksheets(Sayfa_Adı2).Range("A2:d5000").ClearContents
sat = 2
aranan = InputBox("Aranan kelimeyi yazınız.", "bul", "")
If aranan = "" Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If
Set k = Sheets(Sayfa_Adı1).Range("A:IV").Find(aranan, , xlFormulas, xlPart)
If Not k Is Nothing Then
adr = k.Address
Do
If k.Column = 1 Then
sut1 = "burada sutün yok"
Else
sut1 = k.Column - 1
End If
If k.Column = 256 Then
sut2 = "burada sutün yok"
Else
sut2 = k.Column + 1
End If
Sheets(Sayfa_Adı2).Cells(sat, 1).Value = Sheets(Sayfa_Adı1).Cells(k.Row, sut1).Value
Sheets(Sayfa_Adı2).Cells(sat, 2).Value = Sheets(Sayfa_Adı1).Cells(k.Row, k.Column).Value
Sheets(Sayfa_Adı2).Cells(sat, 3).Value = Sheets(Sayfa_Adı1).Cells(k.Row, sut2).Value
Sheets(Sayfa_Adı2).Cells(sat, 4).Value = k.Row & " Satır   " & k.Column & " Sutün"
sat = sat + 1
Set k = Sheets(Sayfa_Adı1).Range("A:IV").FindNext(k)
Loop While Not k Is Nothing And k.Address <> adr
End If
Set k = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Listeleme Yapıldı.."
End Sub

 

[tömbekizade]

Halit Bey çok sağolun, gerçekten harika çalışıyor.
Yalnız birkaç ekleme yapmamız mümkün müdür?

Mesela ben inputbox'ın Sheet 1 'de buton olarak yer almasını tercih ederim.
Bir de galiba ing.-tür. karakter uyumsuzluğundan dolayı türkçe karakterler bozuk çıkyor
örneğin ı harfi y olarak görünüyor. düzeltmenin yolu nedir?

Saygılar,

 

[halit3]

Birinci sorun için Sheet2 sayfasındaki düğme1 komut düğmesini kapyalayıp Sheet1 sayfasına yapıştırınız.

ikinci sorun için bir şey diyemiyeceğim bende türkçe karekterler gayet güzel çalışıyor.

 

[tömbekizade]

Ben ikinci sayfa "düğme 1" diye bir komut düğmesi göremiyorum Halit bey?
Bana ilk yolladığınız versiyonda yok sanırım o.

İkinci sorunum Excel'i ing. kullanmatan kaynaklanıyor olabilir mi acaba?

Saygılar,

 

[halit3]

Ben ikinci sayfa "düğme 1" diye bir komut düğmesi göremiyorum Halit bey?
Bana ilk yolladığınız versiyonda yok sanırım o.

İkinci sorunum Excel'i ing. kullanmatan kaynaklanıyor olabilir mi acaba?

Saygılar,

Evet haklısınız dosyayı eklemeyi unutmuşum.
3 nolu mesaja dosyanızı ekledim.

 

[tömbekizade]

bir de kelimelerin bulunduğu hücre adreslerini link olarak yazdırma şansımız var mı acaba?
tıkladığımızda doğrudan o kelimenin olduğu adrese gitsek daha estetik olur sanki.
tabi gereksiz yere uğraştıracaksa boşverin, bu haliyle zaten muhteşem olmuş.
gerçekten çok sağolun.
saygılar,

 

[halit3]

bir de kelimelerin bulunduğu hücre adreslerini link olarak yazdırma şansımız var mı acaba?
tıkladığımızda doğrudan o kelimenin olduğu adrese gitsek daha estetik olur sanki.
tabi gereksiz yere uğraştıracaksa boşverin, bu haliyle zaten muhteşem olmuş.
gerçekten çok sağolun.
saygılar,

Ekli dosyanızı kontrol ediniz.

Sub ara_bul()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sayfa_Adi1 = "Sheet1"
Sayfa_Adi2 = "Sheet2"
Sheets(Sayfa_Adi2).Hyperlinks.Delete
Sheets(Sayfa_Adi2).Range(Worksheets(Sayfa_Adi2).Cells(2, 1), Worksheets(Sayfa_Adi2).Cells(Rows.Count, Columns.Count)).ClearContents
Sheets(Sayfa_Adi1).Range(Worksheets(Sayfa_Adi1).Cells(2, 1), Worksheets(Sayfa_Adi1).Cells(Rows.Count, Columns.Count)).Interior.ColorIndex = xlNone
Sheets(Sayfa_Adi1).Range(Worksheets(Sayfa_Adi1).Cells(2, 1), Worksheets(Sayfa_Adi1).Cells(Rows.Count, Columns.Count)).FormatConditions.Delete
sat = 2
aranan = InputBox("Aranan kelimeyi yazınız.", "bul", "")
   
If aranan = "" Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If
'Set k = Sheets(Sayfa_Adi1).Range("A:IV").Find(aranan, , xlFormulas, xlPart)
Set k = Sheets(Sayfa_Adi1).Range(Sheets(Sayfa_Adi1).Cells(2, 1), Worksheets(Sayfa_Adi1).Cells(Rows.Count, Columns.Count)).Find(aranan, , xlFormulas, xlPart)

If Not k Is Nothing Then
adr = k.Address
Do
If k.Column = 1 Then
Sheets(Sayfa_Adi2).Cells(sat, 1).Value = "burada 1. sutündan başka sutün yok"
Else
Sheets(Sayfa_Adi2).Cells(sat, 1).Value = Sheets(Sayfa_Adi1).Cells(k.Row, k.Column - 1).Value
End If
If k.Column = Columns.Count Then
Sheets(Sayfa_Adi2).Cells(sat, 3).Value = "burada " & Columns.Count & ". sutündan başka sutün yok"
Else
Sheets(Sayfa_Adi2).Cells(sat, 3).Value = Sheets(Sayfa_Adi1).Cells(k.Row, k.Column + 1).Value
End If
Sheets(Sayfa_Adi1).Cells(k.Row, k.Column).Interior.ColorIndex = 7
Sheets(Sayfa_Adi2).Cells(sat, 2).Hyperlinks.Add Anchor:=Sheets(Sayfa_Adi2).Cells(sat, 2), Address:="", SubAddress:=Sayfa_Adi1 & "!" & k.Address, TextToDisplay:=Sheets(Sayfa_Adi1).Cells(k.Row, k.Column).Value
Sheets(Sayfa_Adi2).Cells(sat, 4).Value = k.Row & " Satır   " & k.Column & " Sutün"
sat = sat + 1
Set k = Sheets(Sayfa_Adi1).Range(Sheets(Sayfa_Adi1).Cells(2, 1), Worksheets(Sayfa_Adi1).Cells(Rows.Count, Columns.Count)).FindNext(k)
'Set k = Sheets(Sayfa_Adi1).Range("A:IV").FindNext(k)
Loop While Not k Is Nothing And k.Address <> adr
End If

Set k = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Listeleme Yapıldı.."
End Sub

 

[tömbekizade]

Halit Bey harikasınız tam istediğim gibi olmuş, elinize sağlık.

Bu arada benim dil sorunum devam ediyor, örneğin sizin yukarıda sayfaya kopyaladığınız kodu da
türkçe karakterleri bozuk olarak görüntülüyorum, örneğin Sayfa_Adı olması gereken isim
Sayfa_Adı olarak gözüküyor. Bununla ilgili önerebileceğiniz birşey var mı?

Saygılar,

 

[halit3]

Halit Bey harikasınız tam istediğim gibi olmuş, elinize sağlık.

Bu arada benim dil sorunum devam ediyor, örneğin sizin yukarıda sayfaya kopyaladığınız kodu da
türkçe karakterleri bozuk olarak görüntülüyorum, örneğin Sayfa_Adı olması gereken isim
Sayfa_Adı olarak gözüküyor. Bununla ilgili önerebileceğiniz birşey var mı?

Saygılar,

Kodları yazarken esasında aksanlı harfleri kullanmamak gerekiyor bazen unutuyoruz okunduğu gibi yazıyoruz doğrusu (Sayfa_Adi) olacak arasında hiç boşluk olmayacak
boşluğa dikkat etmişim ama aksanlı harflere dikkat etmemişim. siz gerekli düzeltmeyi yaparsınız.

 

[tömbekizade]

Halit Bey çok sağolun, gerçekten harika bir kod oldu.
Elinize sağlık.
Saygılarımla,

 

[halit3]

9 nolu mesajdaki dosyayı yeniden derledim bazı hatalar vardı.