Kapalı dosyadan veri al

[polis-53]

merhaba arkadaşlar ekte gönderdiğim klasör içindeki sefa adlı dosyadan icmal sayfasına veri alıyorum sadece B satırındaki verileri alabılıyorum ben ise B,C,D,E,F,G,H... satırlarındaki verileride icmal sayfasına almak istiyorum bir yardım ederseniz çok sevineceğim
Kodlar alıntıdır

 

[doganbaris]

sıkıştırılmış dosyalarda işlem yapamıyorum. B kolonundaki veriyi nasıl alıyorsanız, diğerlerini de aynı şekilde alacaksınız ?

 

[polis-53]

Merhaba doganbaris uğraştım ama yapamadın kod aşağıda bir bakarsanız sevineceğim

Option Base 1
Sub al_topla_ado_59()
On Error Resume Next
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("b2:c65536").ClearContents
sat = Cells(65536, "A").End(xlUp).Row
If sat < 3 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, "b").Value = myarr(2, i)

Next
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı" & vbLf & "email: polis-irfan@hotmail.com" & vbLf & "date : 28.02.2011", vbOKOnly + vbInformation, "P O L İ S"
End If
Erase myarr
Application.ScreenUpdating = True

End Sub

 

[doganbaris]

recordsetler ve database bağlantıları çok tecrübeli olduğum konular değil, benim de öğrenmek istediğim ancaki şu andaki yoğunluğumda çok vakit ayıramıyorum.

Yanlış yönlendirmek istemem, bu nedenle üzülerek yardımcı olamayacağımı belirtmek durumundayım.