Hücre içerisinden birden fazla kelimeyi arama

[Ewoshadow]

Merhaba.

Biraz etrafından dolaşarak oldu ama, (veri yığınının yoğunluğuna göre işlem hızına bir şey diyemiyorum)
sayfadaki SEARCH düğmesiyle aşağıdaki kod'u ilişkilendirerek dener misiniz?

NOT:
-- Aranacak kelime/kelime parçalarını aralara BOŞLUK koyarak yazınız.
-- Sadece BÜYÜK/KÜÇÜK harf duyarlılığına iişkin düzenleme yapılması gerekebilir.
-- Mevcut haliyle AYNEN yazıldığı biçimde arama yapılıyor.
.

[B]Sub AramaBARAN()[/B]
Set ana = Sheets("Ana Sayfa"): Set l = Sheets("Liste")
On Error Resume Next
l.ShowAllData: lson = l.Cells(Rows.Count, 3).End(3).Row
If ana.Cells(Rows.Count, 2).End(3).Row > 19 Then ana.Range("B20:L" & ana.Cells(Rows.Count, 2).End(3).Row).ClearContents

Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
For sat = 6 To 14
    If ana.Cells(sat, 4) = "" Then GoTo 10
    sut = sat - 4
    If sut > 6 Then sut = sut + 1
        aranan = ana.Cells(sat, 4)
        adet = Len(aranan) - Len(Replace(aranan, " ", "")) + 1
        For k = 1 To adet
            kk = Split(aranan, " ")(k - 1)
            For satt = 2 To Sheets("Liste").Cells(Rows.Count, 3).End(3).Row
                If Len(l.Cells(satt, sut).Value) <> Len(Replace(l.Cells(satt, sut).Value, kk, "")) Then
                    l.Cells(satt, 13) = "x"
                End If: Next: Next
10: Next
l.Range("A1:M1").AutoFilter Field:=13, Criteria1:="x"
If l.Cells(Rows.Count, 3).End(3).Row = 1 Then
    l.Range("A1:M1").AutoFilter Field:=13
    Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
    MsgBox "Herhangi bir kniter yazmadınız veya aranan kirterlere ait veri bulunamadı."
    Exit Sub
End If
l.Range("B2:L" & lson).Copy: ana.[B20].PasteSpecial Paste:=xlPasteValues
l.ShowAllData: l.[M:M].ClearContents: ana.Rows("20:" & aha.Cells(Rows.Count, 3).End(3).Row).AutoFit
ana.[B19].Activate
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "ARAMA sonuçları aşağıdaki listelendi." & vbLf & vbLf & _
    "Bulunan kayıt sayısı :  " & ana.Cells(Rows.Count, 2).End(3).Row - 19
[B]End Sub[/B]

Gerçekten ama gerçekten emeğiniz için çok teşekkür ederim. Gerçekten zaman ayırmışsınız.

Bahsettiğim sorunu tam olarak çözmüşsünüz. Denemelerimde bahsettiğim sorunla karşılaşmadım. Sadece iki veya daha fazla arama kutusuna veri girildiği zaman ikisini de arıyordu. Yani Ad kısmına [emre] yazalım yıl kısmına da [1980] yazalım. Emre'nin 1980 de yazdığı kitap önüme geliyordu başkaların 1980 de yazdığı şeyler gelmiyordu, şuan bu çalışmıyor. Sadece tek bir arama verisini kabul ederek arıyor ve diğerini yok sayıyor.

Bahsettiğiniz gibi harf duyarlılığını ve söylediğim bu sorunu nasıl çözebiliriz?Sizden daha fazlasını bekleyerek umarım ayıp etmiyorumdur. Çünkü yazdıklarınız ile benim birkaç haftalık deneyimimin çok üstüne çıkmışsınız. Benim düzeltmem imkansız gibi

Tekrar çok teşekkür ederim cevabınız için.

 

[Ewoshadow]

Şöyle bir eklemeye yapayım; Aranan kriterlerin birleşim kümesini alıyor. Kesişim kümesini aldırabilirsek çok daha kullanışlı olur gibi

 

[Ömer BARAN]

Tekrar merhaba.

Nihai kod cevabım 34 numaralı cevapta.

.

 

[Ömer BARAN]

Son cevabıma küçük bir ilave daha yapmak gerekecek belirttiğim son kod satırının en sonuna küçük bir ilave:

l.Range("A1:M1").AutoFilter Field:=13, Criteria1:=WorksheetFunction.Rept("x", a + 1) & "*"

Böylece bir satırda aynı kriter için yazılmış 1'den fazla eşleşme olduğunda oluşacak sorun halledilmiş olması lazım.
.

 

[Ewoshadow]

Merhaba;
yazdığınızdan beri deniyorum ama sanırım bir yerlerde yanlış yapıyorum. Ne yazarsam yazayım sonuç bulunamadı diyor şu an. Son yazdığınıza ekledim.

 

[Ömer BARAN]

Belgenizde yeterli örnek veri yok veri değiştirerek deneyeceğim.

 

[Ewoshadow]

Bende şu an 15 satır gerçek makalelerle yazılmış liste var isterseniz gönderebilirim.

 

[Ömer BARAN]

Çok iyi olur, ayrıca kriterlere öyle kriterler (bazılarına 1'den fazla olacak şekilde) yazın ki filtre sonucu 1 satır olsun.

 

[Ewoshadow]

http://s7.dosya.tc/server3/kojvdw/pdf_liste.rar.html

denedim sonuç değişmedi, veri bulunamadı diyor. Belki ben bi hata yapmışımdır. Umarım sizi çok uğraştırmaz tekrar çok teşekkür ederim ilginiz için.

 

[Orion1]

Hangi sütun sorgulanacak?

 

[Ewoshadow]

Hangi sütun sorgulanacak?

Listede [B/C/D/E/F/H/I/J/K] Sütünları

 

[Orion1]

Listede [B/C/D/E/F/H/I/J/K] Sütünları

Bu sütunlar için tek bir verimi aranacak,yoksa her bir sütun için ayrı,ayrı verimi aranacak?

 

[Ewoshadow]

Bu sütunlar için tek bir verimi aranacak,yoksa her bir sütun için ayrı,ayrı verimi aranacak?

Her sütun kendi içerisinde aramaya tabi tutulacak sadece bir sütun da aranabilecek yazdıklarım hepsi de, aynı anda ne kadar çok sütun araması yapılırsa ona göre gösterilen veri daraltılacak.

 

[Ömer BARAN]

Yazar adını aramak istemişsiniz ama bu kriteri kitap adı satırına yazmışsınız.

Aranacak şeyi doğru yere yazıp aşağıdaki kod'u dener misiniz?

Başlangıçta (1 kez) belgede liste sayfası M sütununu elle silerek içeriğini boşaltın.
Ana Sayfa 6-14'incü satırlar listede sütunu temsil ediyor ve veri varsa bunlar VE anlamına geliyor,
bir satıra yazılmış bir'den fazla kriter VEYA anlamına geliyor..

Sub AramaBARAN2()
Set ana = Sheets("Ana Sayfa"): Set l = Sheets("Liste")
On Error Resume Next
l.ShowAllData: lson = l.Cells(Rows.Count, 3).End(3).Row
If ana.Cells(Rows.Count, 2).End(3).Row > 19 Then ana.Range("B20:L" & ana.Cells(Rows.Count, 2).End(3).Row).ClearContents

Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
For sat = 6 To 14
    If ana.Cells(sat, 4) = "" Then GoTo 10
    aramalar = aramalar & sat
    a = a + 1: sut = sat - 4
    If sut > 6 Then sut = sut + 1
        aranan = ana.Cells(sat, 4)
        adet = Len(aranan) - Len(Replace(aranan, " ", "")) + 1
        For k = 1 To adet
            kk = Split(aranan, " ")(k - 1)
            For satt = 2 To Sheets("Liste").Cells(Rows.Count, 3).End(3).Row
                If Len(l.Cells(satt, sut).Value) <> Len(Replace(l.Cells(satt, sut).Value, kk, "")) Then
                    If Len(l.Cells(satt, 13)) = a Then GoTo 50
                        l.Cells(satt, 13) = l.Cells(satt, 13) & "x"
50:                 End If: Next: Next
10: Next
l.Range("A1:M1").AutoFilter Field:=13, Criteria1:=WorksheetFunction.Rept("x", a)
If l.Cells(Rows.Count, 3).End(3).Row = 1 Then
    l.Range("A1:M1").AutoFilter Field:=13
    Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
    MsgBox "Herhangi bir kniter yazmadınız veya aranan kirterlere ait veri bulunamadı."
    Exit Sub
End If
l.Range("B2:L" & lson).Copy: ana.[B20].PasteSpecial Paste:=xlPasteValues
l.ShowAllData: l.[M:M].ClearContents: ana.Rows("20:" & ana.Cells(Rows.Count, 3).End(3).Row).AutoFit
ana.[B19].Activate
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "ARAMA sonuçları aşağıdaki listelendi." & vbLf & vbLf & _
    "Bulunan kayıt sayısı :  " & ana.Cells(Rows.Count, 2).End(3).Row - 19
End Sub

 

[Ewoshadow]

M sütununu elle sildikten sonra sistem çalışmaya başladı. Onlarca kez denedim kaydederken son denememde ufak bir hata yapmışım kusura bakmayın.

Bir satıra yazılmış birden fazla veriyi de "ve" yapma ihtimalimiz var mıdır. Çünkü aynı isme sahip dergilerden belki binlerce makale eklenecek, "veya" komutu orada karşımıza binlerce veri gelmesine sebep olabilir. Mesela Publication Title kısmına Masrop 9 yazarak deneyiniz. History volume 9 da gösteriyor size bunların sayısı artarsa sorun büyüyebilir. Onun dışında her şey çok güzel gerçekten elinize sağlık. Süpersiniz.

 

[Orion1]

Dosyanız ekte.
G sütununda boston ve leiden sorgulanıyor,İstereseniz siz 3ncü veriyide s3 diye iptal ettiğim yere yazınız.
Q sütunundan itibaren veriler aktarılıyor.
Geç oldu.Ben çıkıyorum.

DOSYAYI İNDİR

Sub adoileara59()
Dim conn As Object, rs As Object, s1 As String, s2 As String, s3 As String
Range("Q2:AA" & Rows.Count).ClearContents
Set conn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
s1 = "Boston"
s2 = "Leiden"
's3 = "Köln"
conn.Open ("Provider=microsoft.ace.oledb.12.0;data source=" & _
        ThisWorkbook.FullName & ";extended properties=""excel 12.0;hdr=no""")
rs.Open "select * from [Liste$B2:M65536] where F6 like '%" & s1 & _
        "%' and F6 like '%" & s2 & "%' and F6 like '%" & s3 & "%'", conn, 1, 1
Range("Q2").CopyFromRecordset rs
rs.Close: conn.Close
Set rs = Nothing: Set con = Nothing
MsgBox "Veriler aktarıldı." & vbLf & "evrengizlen@hotmail.com"

End Sub

 

[Orion1]

Kodlarda bazı yerlere eklemler ve değişiklikler yaptım.Önceki mesajımdaki linkteki dosyayı tekrar indiriniz.

 

[Ömer BARAN]

Öncelikle, son kod cevabımda, deneme yaparken yazdığım iki satırın silinmesi gerekiyor .
Bunlardan biri, bir=...... şeklinde , diğeri de hemen altındaki iki=.... şeklinde satırlar idi.
(son cevabımı güncelledim, sayfayı yenileyerek bu satırların silindiğini görebilirsiniz)

Son isteğiniz ile ilgili önerim aşağıdaki gibi (bu söylediğimi önceki cevabımdaki koda işlemedim, tamam derseniz işleyeceğim).
Şöyle bir çözüm düşündüm; şayet aranmak istenen Volume 24 ise;
bu metni aradaki boşluk yerine _ (alt tire) karakteriyle ayırarak yani Volume_24 şeklinde yazarak yapmak uygun olabilir.
Bu durumda aramanın, Volume VEYA 24 şeklinde değil de Volume 24 (alt tiresiz, boşluklu) şeklinde yapılması sağlanmış olur.

Bunun için; son verdiğim koddaki kk = Split(aranan, " ")(k - 1) satırından sonra yeni bir satır olarak aşağıdaki satırı eklemeniz yeterli olur.
If Len(Replace(kk, "_", "")) <> Len(kk) Then kk = Replace(kk, "_", " ")
.

 

[Ewoshadow]

Hayır sadece aranmak istenen şey Volume 24-25 vs. değil mesela Meterial kısımda binlerce Pottery ifadesi olabilir ve liste dolmaya başladığında olacak yada başka bir şey sürekli tekrar edecek. Mesela Rome Hellenistic, Classical age genel tabirler, dönemler olduğu için tekrar edecekler, burada karşımıza çıkacak olan bir kargaşayı önlemek istemiştim ama olmuyorsa yapacak bir şey yok sadece harf duyarlılığının önüne geçersek yeterli olur sanırım. zaten sizin vaktinizi fazlasıyla aldım. Çok teşekkür ederim ilgilendiğiniz için, gerçekten hakkınızı ödeyemem Sağolun. :dua2:

 

[Ewoshadow]

Kodlarda bazı yerlere eklemler ve değişiklikler yaptım.Önceki mesajımdaki linkteki dosyayı tekrar indiriniz.

İlginiz ve cevabınız için teşekkür ederim ancak sanırım tam olarak anlatamadım kendimi, Ömer Baran'nın yaptığı gibi bir arama kısmı istemiştim tüm kriterler için farklı farklı aramalar sadece Publication için değil. Yine de zaman ayırdığınız için teşekkür ederim.Çok Sağolun.