Kapalı excel dokumanından şartlı hücre listelemek

[sakiogluo]

C:\[Veri_tabanı.xls] olarak kapalı excel dokümanından belli harflerle başlayan hücreleri listelemek istiyorum. Ekteki dokumanda açıklaması var. Yardımcı olan olursa sevinirim.

 

[Orion1]

Dosyanız ekte.

Private Sub CommandButton1_Click()
Dim son As Long, deg As String, i As Long, sat As Long
Application.ScreenUpdating = False
Range("A2:A65536").ClearContents
son = Application.ExecuteExcel4Macro("COUNTA('C:\[Veri_tabanı.xls]Sayfa1'!C2)")
sat = 2
For i = 1 To son
    deg = Application.ExecuteExcel4Macro("'C:\[Veri_tabanı.xls]Sayfa1'!R" & i & "C2")
    If UCase(Replace(Replace(deg, "i", "İ"), "ı", "I")) Like UCase(Replace(Replace(Range("B1").Value, "ı", "I"), "i", "İ")) Then
        Cells(sat, "A").Value = deg
        sat = sat + 1
    End If
Next
Application.ScreenUpdating = True
MsgBox "İşlem tamamadır..!!", vbOKOnly + vbInformation, "LİSTE"
End Sub

 

[sakiogluo]

Sayın, Evren Gizlen
Yardımız için çok teşekkür ederim. Fonksiyon çalışıyor yalnız listeleme işlemi 4 buçuk dakika sürüyor ve

Run-time error '13':
Type mismatch

hata mesajı çıkıyor, acaba problem nedir?
Bu arada Office 2007 kullanıyorum ondan kaynaklanıyor olabilirmi?

 

[Tarkan VURAL]

Stok listele

Aşağıdaki kodda ADO yöntemi ile kapalı dosyadan veri alma konusunda, verilerinizi 1 saniyeden daha az zamanda alabilirsiniz.

Örnek dosyaları ekliyorum.

Sub verileri_al()
Dim conn As ADODB.Connection, rs As ADODB.Recordset, sorgu As String
Dim evn As String, i As Long
Set conn = New ADODB.Connection: Set rs = New ADODB.Recordset
evn = InputBox("Aranacak Filtre Kelimesini Giriniz", "[COLOR="Red"]www.excel.web.tr[/COLOR]", "Gİ")
conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.Path & "\veritabanidosyasi.xls;" & _
                                                                "Extended Properties=""Excel 8.0;HDR=Yes"""
sorgu = "select A,B,C FROM [veritabani$]"
rs.Open sorgu, conn, 1, 3
rs.MoveFirst
For i = 1 To rs.RecordCount
uz = Len(evn)
If evn = Mid(rs("B"), 1, uz) Then
    [a65536].End(3)(2, 1) = rs("a")
    [b65536].End(3)(2, 1) = rs("b")
    [c65536].End(3)(2, 1) = rs("c")
End If
rs.MoveNext
Next i
rs.Close: conn.Close
    Set rs = Nothing
        Set conn = Nothing
            sorgu$ = Empty
Exit Sub
End Sub

 

[sakiogluo]

Tarkan Bey, yardımınız için teşekkür ederim. Program gerçekten hızlı çalışıyor. 4000 satırda bile hızla listeleme yapabiliyorum. Sizden ricam sorgulama öncesi

Range("A2:C65536").ClearContents

fonksiyonunu ekleyebilirmisiniz, ben denedim başaramadım. Birde "veritabanidosyasi.xls" dokümanını C:\ altından görmek mümkün mü?
Tekrar teşekkürler.

 

[Tarkan VURAL]

Data Source=" & ThisWorkbook.Path & "\veritabanidosyasi.xls;"

Burayı Data Source="c:\veritabanidosyasi.xls;" olarak değiştirin.

Silme/temizleme de çalışır ama uygun yere yazarsanız. Mesela
Set conn = New ADODB.Connection: Set rs = New ADODB.Recordset
satırından sonra Range("A2:C65536").ClearContents kodunuzu ekleyin.

Bu arada filtrelenecek veriyi boş geçerseniz tüm veritabanınızı dökecek.
Onun da hız farkını deneyin isterseniz

 

[sakiogluo]

Temizleme fonksiyonu çalıştı ama C:\ adreslemesi hata veriyor. Hatanın resmini ekledim.

 

[Tarkan VURAL]

ADO dosya

Source 'den sonraki tırnağı kaldırın,, sanırım fazla kaçmış