KApALI DOSYALARDAN ALMA (10 YIL)

[mars2]

İyi Günler;
1 (bir) dosyadan değil, yıllar toplamı klasörü içinde bulunan yıllara ait dosyalardan veri almak istiyorum.

Her yıla ait veriler farklı çalışma kitbında bulunmak olup, "toplam" sayfasında ise müşterilerin hangi ay ne kadar ödeme yaptığı ve yıllık toplamları bulunmaktadır.

Bu yıllardan farklı olarak ayrı çalışma kitabında (yıllar toplamı) yapılan tabloda ise yılların ay ve toplamını tek bir tabloda almak istiyorum. Hangi yıl ve ayda ne kadar ödeme yaptığını, eksik ödemede bulunup bulunmadığını takip etmek için. Bu çalışma kitabındaki tablonun bulunduğu sayfadaki B1 hücresine müşterinin adını yazılınca ay/yıl bu hücrelere aktaran makro veya buna ait örnek için şimdiden teşekkürler.
örnek klasör ektedir.

 

[Zeki Gürsoy]

>Aşağıdaki kodu sonuçların geleceği sayfanın kod penceresinde kullanın.
>Büyük/küçük harf duyarlı değildir ancak kritere ( B1 hücresi ) Türkçe harf yazmayın.
>"Yıllar toplamı" klasörünü ben "C:\" altında varsaydım. Gerçek yolu kendinize göre değiştiriniz.

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$B$1" Then Exit Sub

Dim arr() As Variant, ADOcn As Object, ADOrs As Object, i%, j%
[COLOR=Navy][B]Const iPath As String = "C:\Yıllar toplamı\"[/B][/COLOR]

On Error Resume Next
arr = Array( _
        "1997", "1998", "1999", "2000", "2001", "2002", "2003", "2004", _
        "2005", "2006", "2007", "2008")

Set ADOcn = CreateObject("ADODB.Connection")
Set ADOrs = CreateObject("ADODB.Recordset")

[b7:m18].ClearContents

For i = 0 To UBound(arr)
    ADOcn.Open _
        "Driver={Microsoft Excel Driver (*.xls)};Dbq=" & _
           iPath & arr(i) & ".xls"
           
    ADOrs.Open _
            "Select * From [toplam$] Where [Ad Soyad] Like '" & [b1] & "'", ADOcn
            
    For j = 1 To 12
        Cells(j + 6, i + 2) = ADOrs(j)
    Next
    
    ADOrs.Close
    ADOcn.Close
Next

Set ADOrs = Nothing
Set ADOcn = Nothing
Erase arr
End Sub

 

[mars2]

Sayın Zeki Gürsoy;

cevabınız için teşekkürler. Ancak dosyayı da eklerseniz sevinirim.

 

[bluefalcon]

Süper bişey bu yahu.Ellerinize sağlık...

 

[Zeki Gürsoy]

Sayın Zeki Gürsoy;

cevabınız için teşekkürler. Ancak dosyayı da eklerseniz sevinirim.

Dosya, üstteki mesajıma eklidir.

 

[cenderus]

dosya tekrar eklenmiştir

dosya tekrar eklenmiştir