Klasörün içindeki dosyalardan verileri almak

[polis-53]

merhaba arkadaşlar öncelikle herkese kolay gelsin
benim bir sorum olacak örneğin bir klasör içinde 20 den fazla dosyam var bu dosyalarımın formantı hepsinde aynıdır benim istediğim bu klasörün içinde ki dosyalarımın bir tanesini icmal dosyası olarak kullanacağım klasörün içindeki diğer dosyaların C sütünündaki verileri icmal dosyasındaki c sutununa toplatmak istiyorum yardımlarınızı bekliyorum şimdiden teşekkür ederim.
ekte örek tosya ekledim.

 

[Orion1]

Dosyanız ektedir.

Option Base 1
Sub al_topla_ado_59()
'CODER : Evren GİZLEN
'email : evrengizlen@hotmail.com
'Date : 28.02.2011
Dim conn As ADODB.Connection, rs As ADODB.Recordset
Dim z As Object, a As Long, fso As Object, f, dosya As String
Dim sat As Long, i As Long, list(), myarr(), n As Long
Sheets("Sayfa1").Select
Application.ScreenUpdating = False
Range("C2:C65536").ClearContents
sat = Cells(65536, "A").End(xlUp).Row
If sat < 2 Then
    MsgBox "A sütununda veri yok.'nci satırdan itibaren verileriniz olmalı", vbCritical, "U Y A R I"
    Application.ScreenUpdating = False
End If
ReDim myarr(1 To 2, 1 To sat)
Set fso = CreateObject("Scripting.filesystemobject")
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
Set z = CreateObject("scripting.Dictionary")
list = Range("A2:A" & sat).Value
For i = 1 To UBound(list)
    If Not z.exists(list(i, 1)) Then
        n = n + 1
        z.Add list(i, 1), n
        myarr(1, n) = i
    End If
Next
Erase list
For Each f In fso.getfolder(ThisWorkbook.Path).Files
    dosya = f.Name
    If dosya <> ThisWorkbook.Name Then
        conn.Open "provider=microsoft.jet.oledb.4.0;data source=" & f & _
        ";extended properties=""excel 8.0;hdr=no"""
        rs.Open "select first(F1),sum(F2) from [Sayfa1$A2:B65536] GROUP BY F1 ORDER BY F1;" _
        , conn, adOpenKeyset, adLockReadOnly
        If rs.RecordCount > 0 Then rs.MoveFirst
        Do While Not rs.EOF
            If z.exists(rs(0).Value) Then
                myarr(2, z.Item(rs(0).Value)) = myarr(2, z.Item(rs(0).Value)) + rs(1).Value
            End If
            rs.MoveNext
        Loop
        rs.Close
        conn.Close
    End If
Next
Set rs = Nothing
Set conn = Nothing
Set fso = Nothing
Set z = Nothing
ReDim Preserve myarr(1 To 2, 1 To UBound(myarr, 2))
If UBound(myarr) > 0 Then
    For i = 1 To UBound(myarr, 2)
        If myarr(1, i) <> "" And IsNumeric(myarr(1, i)) Then Cells(myarr(1, i) + 1, "C").Value = myarr(2, i)
    Next
    Application.ScreenUpdating = True
    MsgBox "İşlem tamamlandı" & vbLf & "email: evrengizlen@hotmail.com" & vbLf & "date : 28.02.2011", vbOKOnly + vbInformation, "E V R E N"
End If
Erase myarr
Application.ScreenUpdating = True
End Sub

 

[polis-53]

Sayın Evren Gizler çok teşekkür ederim fakat icmal dosyasındaki tıkla butonuna tıkladığım zaman dosyadaki değerler siliniyor benim istediğim diğer dosyalardaki değerlerin toplayarak icmal sayfasındaki karşılık gelen yerlere aktarmaktır.

 

[polis-53]

Evren gizler

merhaba evrez gizler çoooook teşekkür ederim başlıkları yani satırlar ve sütünlar çoğaldığı zaman hesaplamıyor birde bazı dosyalarda bazı satır veya sütünlarda rakam olmayabilir böylede hesaplandığında hata vermeyecek bir bakarsanız çok sevineceğim. kısaca satır ve sutunları istediğim kadar çoğaltabilmeliyim

 

[Orion1]

Sayın Evren Gizler çok teşekkür ederim fakat icmal dosyasındaki tıkla butonuna tıkladığım zaman dosyadaki değerler siliniyor benim istediğim diğer dosyalardaki değerlerin toplayarak icmal sayfasındaki karşılık gelen yerlere aktarmaktır.

Bu istediğinize göre 2 numaralı mesajda güncelleme yaptım kodları.
Kolay gelsin.

 

[Orion1]

merhaba evrez gizler çoooook teşekkür ederim başlıkları yani satırlar ve sütünlar çoğaldığı zaman hesaplamıyor birde bazı dosyalarda bazı satır veya sütünlarda rakam olmayabilir böylede hesaplandığında hata vermeyecek bir bakarsanız çok sevineceğim. kısaca satır ve sutunları istediğim kadar çoğaltabilmeliyim

Bu olmaz
Anladığım kadarı ile ayni sütunda
bazı değerler metin bazılarıda sayı.
Bu durumda benim yazdığım kodlar çalışmaz.Yada hatalı sonuç üretir.
Çünkü ben ado kullandım.
Ado disiplin ister.Çorba veya hoşaf olmamamalı alanlarınız.
Yaptığınız işleri tasarlarken buna dikkat etmelisiniz.
En hızlı çalışan kodlar bunlardır.
Aksi durumda başka çözüm aranır
ama o kodlar büyük veri yığınlarında tavşanın yanında tospaha gibi olurlar.
İsterseniz elinizde kıyasalayabailecek yazılmış kod varsa büyük veri yığınları(40 bin - 50 bin satır) oluşturup deneyin.O zamana ne demek istediğimi daha iyi anlarsınız.
Kolay gelsin.