Otomatik süzme ve arama

[hlojan]

Bir konuda gördüm bir türlü accesse uyarlayamadım

Option Explicit

Sub Sil()
    Range("B9:I3000").ClearContents
End Sub


Private Sub TextBox1_Change()
Dim sonsat As Long, Deg As String, hcr As Range, Aln As Range, Code As Boolean
Dim vsyf As Worksheet, renk

    Sheets("ARAMA").Activate
        
        If Range("E3") <> "" Then
            Deg = Range("E3").Value
            
        Else
            MsgBox "BİR ARAMA KRİTERİ GİRİN..."
            Exit Sub
        End If
        
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Set vsyf = Sheets("VERİ")
    Range("A9:I3000").ClearContents


    sonsat = vsyf.Range("A" & Rows.Count).End(xlUp).Row
    vsyf.Range("B2").AutoFilter
    
    vsyf.Range("B2").AutoFilter Field:=3, Criteria1:="=*" & Deg & "*"
    
    vsyf.Range("B2:I" & sonsat).SpecialCells(xlCellTypeVisible).Copy Range("B9")
    vsyf.Range("B2").AutoFilter


    sonsat = Range("B" & Rows.Count).End(xlUp).Row
          Set Aln = Range("C9:C" & sonsat)
        
    For Each hcr In Aln
        renk = InStr(renk + 1, hcr.Text, Deg)
        Do
            If renk > 0 Then
                hcr.Characters(Start:=renk, Length:=Len(Deg)).Font.ColorIndex = 7
            End If
            renk = InStr(renk + 1, hcr.Text, Deg)
        Loop While renk > 0
    Next hcr

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

Bu kodla aynı çalışma kitabındaki farklı sayfadaki listeyi süzme işlemi yapıyor. Database nasıl uygularım

Örnek dosya ekte. Yardımlarınızı bekliyorum

 

[hlojan]

Konuda ala çözüme ulaşamadım yardımlarınızı bekliyorum

 

[Erdem Akdemir]

Sorunuz anlaşılır değil.

 

[hlojan]

Tekrar açıklayım. Yukarıdaki kod aynı çalışmma kitabındaki farklı sayfadaki veri listesini süzüyor. ve listeliyor.

Benim işime en yarayan kısmı ise arama yaparken kelimenin ortasındanda anahtar sözcükleri süzmesi.

Combobox ile yapıyorum kelimenin başı aynıysa anımsayıp süzüyor.

ÖRNEK : Arama > 12
sonuç ; 1254 ; 5124 ; 00012 ;

Tanımlamalar

Dim sonsat As Long, Deg As String, hcr As Range, Aln As Range, Code As Boolean
Dim vsyf As Worksheet, renk

Arama hücresinin boş uyarısı

 Sheets("ARAMA").Activate
        
        If Range("E3") <> "" Then
            Deg = Range("E3").Value
            
        Else
            MsgBox "BİR ARAMA KRİTERİ GİRİN..."
            Exit Sub
        End If

Listelenecek sayfanın temizlenmesi ve veri süzülcek sayfanın tanımlanması

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Set vsyf = Sheets("VERİ")
    Range("A9:I3000").ClearContents

Ama ben listelemeyi Access tablomdan yapacağımdan

Set vsyf = Sheets("VERİ")

ihtiyacım olmayacak

Asıl değiştirme yapmak istediğim kısım bu. bu kısımda ADOdb ile Accessdeki tablomu Autofilter yapmak istiyorum

sonsat = vsyf.Range("A" & Rows.Count).End(xlUp).Row
    vsyf.Range("B2").AutoFilter
    
    vsyf.Range("B2").AutoFilter Field:=3, Criteria1:="=*" & Deg & "*"
    
    vsyf.Range("B2:I" & sonsat).SpecialCells(xlCellTypeVisible).Copy Range("B9")
    vsyf.Range("B2").AutoFilter


    sonsat = Range("B" & Rows.Count).End(xlUp).Row
          Set Aln = Range("C9:C" & sonsat)

azbucuk bilgim kadarıyla yukardaki kısımda adodb bağlancaz

Private Sub CommandButton1_Click()
Dim con As Object, rs As Object
yol = ThisWorkbook.Path & "\DATA.accdb"
Set con = CreateObject("Adodb.connection")
Set rs = CreateObject("Adodb.recordset")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & yol & ""
rs.Open "select * from [VERİ] where field1='" & Worksheets("ARAMA").Range("E3").Text & "';", con, 1, 1
----
[COLOR="Red"]yapılacak işlem[/COLOR]-----
rs.Close
con.Close
Set rs = Nothing: Set con = Nothing
End Sub

Bu kısımda renklendirme yapıyor. aranan kelimenin bulunan sonuçlardaki yerlerinde

   For Each hcr In Aln
        renk = InStr(renk + 1, hcr.Text, Deg)
        Do
            If renk > 0 Then
                hcr.Characters(Start:=renk, Length:=Len(Deg)).Font.ColorIndex = 7
            End If
            renk = InStr(renk + 1, hcr.Text, Deg)
        Loop While renk > 0
    Next hcr

Bu konu hakkında baya araştırma yaptım. Access üstünden dinamik arama yapılıyor. Ama excel üstünden yapmam gerekiyor.

Daha temiz bir örnek ekledim

Yardımlarınızı bekliyorum

 

[Erdem Akdemir]

Tam istediğinizi hala anlamadım ama sizin aradığınız like operatörü diye düşünüyorum.

Aşağıdaki kodu örnek olması açısından gönderiyorum. Kendi dosyanıza uyarlayabilirsiniz.

Sub deneme()
Columns("d:d").Clear

Set con = VBA.CreateObject("adodb.Connection")
Columns("A:A").NumberFormat = "@"

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""

sorgu = "select f1 from [sayfa1$] where f1 like '%12%' "

Set rs = con.Execute(sorgu)

Range("d1").CopyFromRecordset rs

Columns("A:A").NumberFormat = "General"

End Sub

 

[hlojan]

Harikasınız. Bugün bir şey daha öğrendim. From WHERE LİKE

Acces ve ADO bir nimet excel için

daha fazla şey öğrenmek dileği ile iyi çalışmalar

 

[hlojan]

Bişey daha sormak istiyorum. ek olarak

Set rs = con.Execute(sorgu)

Range("d1").CopyFromRecordset rs

mesala 12 yazdığımda sonuçları buluyor. 560 tane mesala

ilk 20 sonuç listelenmesi için bi kod ekleyebilirmiyiz

 

[Erdem Akdemir]

merhaba,

Sorgudaki kısmı aşağıdaki ile değiştirin.

sorgu = "select top 20 f1 from [sayfa1$] where f1 like '%12%' "