Kapalı dosyadan verileri neden sıfır(0) alıyor

[mars2]

İyi Günler;
Kapalı dosyadan veri alma daha önceden de yardım aldım ancak, isim bazında almaya çalıştığımda veri olmasına rağmen hep sıfı(0) almaktadır. neden?

Dim conn As ADODB.Connection, rs As ADODB.Recordset ile

örnek doysa ektedir.

Şimdiden yardımlarınız için teşekkürler.

 

[Levent Menteşoğlu]

Dosyanızdaki verial prosedürünü aşağıdaki ile değiştirerek deneyin. Kırmızı renkli satırlar ilave edilmiş ve mavi renkliler düzeltilmiştir.

Sub verial()
Dim conn As ADODB.Connection, rs As ADODB.Recordset
Dim j As Integer, i As Byte, tpl As Double, dosya As String, son As Integer
Dim no As String, arr()
Sheets("yıllar").Select
If Range("B12").Value = "" Then
    MsgBox "Dosya Numarası boş" & vbLf & "Bir dosya numarsı girmelisiniz.", vbCritical, "UYARI"
    Range("B12").Select
    Exit Sub
End If
no = Range("B12").Value
Range("B21:IV32").ClearContents
son = Cells(20, "IV").End(xlToLeft).Column
Application.ScreenUpdating = False
For j = 2 To son
    If Dir(ThisWorkbook.Path & "\" & Cells(20, j).Value & ".xls") <> "" Then
        Set conn = New ADODB.Connection
        Set rs = New ADODB.Recordset
        conn.Open ("provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\" & Cells(20, j).Value & ".xls;extended properties=""excel 8.0;hdr=no[COLOR=red][B];IMEX=1"";")[/B][/COLOR]
        rs.Open "Select * from [toplam$c2:P65536][COLOR=red][B] where F1='" & [b12] &[/B][/COLOR] "';", conn, adOpenKeyset, adLockReadOnly
        arr = Array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
        rs.MoveFirst
            Do While Not rs.EOF
                   For i = 21 To 32
                        If Not IsNull(rs(i - [B][COLOR=blue]20[/COLOR][/B]).Value) Then
                            arr(i - 20) = arr(i - 20) + rs(i - [COLOR=blue][B]20[/B][/COLOR]).Value
                        End If
                    Next i
                rs.MoveNext
            Loop
        rs.Close
        Set rs = Nothing
        conn.Close
        Set conn = Nothing
        For t = 21 To 32
            Cells(t, j).Value = arr(t - 20)
        Next
        Erase arr
    End If
Next j
Application.ScreenUpdating = True
MsgBox "İŞLEM TAMAMLANMIŞTIR." & vbLf & _
"DOSYA BAZINDA 2009-2024 YILLARI İÇİN", vbOKOnly + vbInformation, "S E R V İ S İ"
End Sub

 

[mars2]

Sayın Levent Menteşoğlu;
yardımınız için teşekkürler.

 

[mozdem]

Bende neden hata veriyor??

verilen dosya benimde işime yarayacağını düşündüm ve hocanın yazmış olduğu koduda kopyala-yapıştır yaptıktan sonra da öncesindede;
ilk satırda

Dim conn As ADODB.Connection, rs As ADODB.Recordset


İlk satırda hata verip duruyor.

***********
HATA
Compile error,
can't find project or library
'***************
ADODB.Connection, ADODB.Recordset ile kapalı dosyalardan veri alırken ayarlama yapmam gereken bir şey mi var.

Yardımlarınızı bekliyorum

 

[Levent Menteşoğlu]

verilen dosya benimde işime yarayacağını düşündüm ve hocanın yazmış olduğu koduda kopyala-yapıştır yaptıktan sonra da öncesindede;
ilk satırda

Dim conn As ADODB.Connection, rs As ADODB.Recordset


İlk satırda hata verip duruyor.

***********
HATA
Compile error,
can't find project or library
'***************
ADODB.Connection, ADODB.Recordset ile kapalı dosyalardan veri alırken ayarlama yapmam gereken bir şey mi var.

Yardımlarınızı bekliyorum

Kod tasarlanırken erken bağlanma (early binding) yöntemi kullanıldığı için ilgili referansın işaretli olması gerekir. Eğer CreateObject("ADODB.Connection") şeklinde ifade edilen geç bağlanma (late binding) yöntemi kullanılsaydı bu referansın işaretlenmesi zorunluluğu kalmayacaktı.

VB editöründe referans penceresinde "Microsoft Activex Data Objects ... Library" seçeneğinden en yüksek versiyonunun kutusunu işaretleyin.

Kodu aşağıdaki gibi geç bağlanma (late binding) olarakta düzenleyerek referansı işaretlemeden de çalıştırabilirsiniz. Bunuda faydalı olacağını düşündüğüm için bir ek bilgi olarak veriyorum.

Not: Kod içindeki kırmızı renkli ifadelere dikkat edin.

Sub verial()
Dim j As Integer, i As Byte, tpl As Double, dosya As String, son As Integer
Dim no As String, arr()
Sheets("yıllar").Select
If Range("B12").Value = "" Then
    MsgBox "Dosya Numarası boş" & vbLf & "Bir dosya numarsı girmelisiniz.", vbCritical, "UYARI"
    Range("B12").Select
    Exit Sub
End If
no = Range("B12").Value
Range("B21:IV32").ClearContents
son = Cells(20, "IV").End(xlToLeft).Column
Application.ScreenUpdating = False
For j = 2 To son
    If Dir(ThisWorkbook.Path & "\" & Cells(20, j).Value & ".xls") <> "" Then
        Set conn = [COLOR=red][B]CreateObject("ADODB.Connection")[/B][/COLOR]
        Set rs = [B][COLOR=red]CreateObject("ADODB.Recordset")[/COLOR][/B]
        conn.Open ("provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\" & Cells(20, j).Value & ".xls;extended properties=""excel 8.0;hdr=no;IMEX=1"";")
        rs.Open "Select * from [toplam$c2:P65536] where F1='" & [b12] & "';", conn, [B][COLOR=red]1[/COLOR][/B], [COLOR=red][B]1[/B][/COLOR]
        arr = Array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
        rs.MoveFirst
            Do While Not rs.EOF
                   For i = 21 To 32
                        If Not IsNull(rs(i - 20).Value) Then
                            arr(i - 20) = arr(i - 20) + rs(i - 20).Value
                        End If
                    Next i
                rs.MoveNext
            Loop
        rs.Close
        Set rs = Nothing
        conn.Close
        Set conn = Nothing
        For t = 21 To 32
            Cells(t, j).Value = arr(t - 20)
        Next
        Erase arr
    End If
Next j
Application.ScreenUpdating = True
MsgBox "İŞLEM TAMAMLANMIŞTIR." & vbLf & _
"DOSYA BAZINDA 2009-2024 YILLARI İÇİN", vbOKOnly + vbInformation, "S E R V İ S İ"
End Sub

 

[mozdem]

Çok Teşekkürler

Hocam ellerinize sağlık Çok teşekkür ederim.

 

[mars2]

İyi Günler;

Program çalışırken rs.MoveFirst hatası vermektedir neden.
Teşekkürler.

 

[zehnisağcan]

merhaba sevgili exel web.tr.

ben bu çalışmayı denemek istedim nasıl çalışıyor diyor arkadaşın bahsettiği sorunları yaşadım ve mesajları okuyorak çözdüm ama.

" Set conn = CreateObject("ADODB.Connection")" bu satırda "conn =" mavi olarak hata veriyorç neden dir acaba levent hocaM İLGİLENİRSE VEYA DEĞERLİ BAŞKA HOCALARIM BAKABİLİRSE MEMNUN OLURUM.

SAYGILAR

 

[mars2]

İyi Günler;
Yukarıdaki kod ile verileri almaktayım. Ancak aynı kodu dosya nosuna uyguladığımda 47-735 yazdığımda verileri vermemekte ancak,yalnız 735 yazdığımda verileri vermektedir. nasıl düzeltebiliriz.