Kapalı dosyadan veri alma

[Orion1]

Sayın Evren;
Sutun başlıklarına baktım ancak, yine olmuyor yine olmuyor.

Ne oluyor ? hatamı veriyor.
Dosyaları yollayın bakayım.

 

[mars2]

Sayın Evren Gizlen;
dosyalar ektedir. İlginize şimdiden teşekkürler.

 

[Orion1]

Sayın Evren Gizlen;
dosyalar ektedir. İlginize şimdiden teşekkürler.

Ama şimdi sağ gösterip sol vuruyorsunuz.
Tabii bizde abondone oluyoruz.
Şimdi söylermisiniz.Bu çalıştırmak istediğiniz kodlar benim size en son yolladığım çalışan kodlarmı?

 

[Orion1]

Dediğim gibi
Kaynak dosyalardaki B5 hücrelerindeki Taşınmaz No olan arsında boşluk olan sütun başlıklarını Taşınmaz_No bu şekilde tre yaptım.
Ve korhan beyin sizi uyardığı gibi microsoft activex data object 2.8 i referanslardan işaretledim.Ve ado ile verileri çok rahat aldım.Dosyalarınız ektedir.

 

[mars2]

Sayın evren;
Sizden özür diliyorum. göndereceğim asıl örneği göndermemişim. şimdi gönderiyorum.

 

[Orion1]

Dosyanız ektedir.

Sub yillaritopla()
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 Variant, arr()

Sheets("geneltoplam").Select
If Range("B4").Value = "" Then
    MsgBox "Dosya Numarası boş" & vbLf & "Bir dosya numarsı girmelisiniz.", vbCritical, "UYARI"
    Range("B4").Select
    Exit Sub
End If
no = Range("B4").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""")
        rs.Open "Select * from [yiltoplami$A6:N65536];", 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
                'MsgBox rs(1)
                If rs(1).Value = no Then
                    For i = 21 To 32
                        If Not IsNull(rs(i - 19).Value) Then
                            arr(i - 20) = arr(i - 20) + rs(i - 19).Value
                        End If
                    Next i
                End If
                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, "K A Y Y I M L I K S E R V İ S İ"

Dim a As Variant

a = InputBox("KAÇ ADET KİRA TAKİP CETVELİ GEREKLİ?", "KİRA TAKİP CETVELİ", "")
If a = Empty Or a = 0 Then Exit Sub
If IsNumeric(a) And a <> vbNullString Then
ActiveSheet.PrintOut
End If

End Sub

 

[Orion1]

Dosyaları kaldırdım.
İçinde gerçek veriler olma ihtimali var diye düşündüm.
Dosyanız bende.İsterseniz yollarım.email adresiniz iverirseniz yoolarım
veya yukarıda verdiğim kodları öncekini üstüne yapıştırın.Öncekini silin.Yine çalışır.

 

[mars2]

Dosyaları kaldırdım.
İçinde gerçek veriler olma ihtimali var diye düşündüm.
Dosyanız bende.İsterseniz yollarım.email adresiniz iverirseniz yoolarım
veya yukarıda verdiğim kodları öncekini üstüne yapıştırın.Öncekini silin.Yine çalışır.

Sayın Evren Gizlen;
İlgi ve yanlayışınıza teşekkürler. İstediğim gibi olmuş ancak, bazı dosya numalarında verileri almamaktadır.
örnek 35083561095 almamakta, 40-14601 almakta neden olabilir. Bu sorunuda çözebilirsek herşeyde halledilmiş olacaktır.

 

[Orion1]

Sayın Evren Gizlen;
İlgi ve yanlayışınıza teşekkürler. İstediğim gibi olmuş ancak, bazı dosya numalarında verileri almamaktadır.
örnek 35083561095 almamakta, 40-14601 almakta neden olabilir. Bu sorunuda çözebilirsek herşeyde halledilmiş olacaktır.

Ben dosyaları silmişim.
evrengizlen@hotmail email adresime yollayın bakayım.

 

[mars2]

Sayın Gizlen;
dosyaları
evrengizlen@hotmail email adresine yolladım.
__________________

 

[Orion1]

Sayın Gizlen;
dosyaları
evrengizlen@hotmail email adresine yolladım.
__________________

Dosyanızı yaptım
email adresinize yolladım.