Diğer dosyalardan veri alma

[unalh]

S.a Arkadaşlar,

Ekte sayım adında bir klasör mevcut
Burada yapmak istediğim sayım klasörünün içersindeki diğer klasörlerden sayım listesine verileri aldırmak.
Diğer klasörlerde her dönem eklemeler olacağından yaptığım küçük formdan seçim yaparak verileri aldırmak.

İlginize şimdiden teşekkür ederim.

 

[Orion1]

Dosyanız ektedir.
Tools==> referenceden microsoft activex data object 2.x eklendi.

Dim conn As ADODB.Connection, rs As ADODB.Recordset
Private Sub CommandButton1_Click()
Dim fso As Object, dosya
Dim ds, f, f1, fc, s, sat As Long
If ComboBox1.Value = "" Then Exit Sub
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder(ThisWorkbook.Path)
Set fc = f.SubFolders
Sheets("Sayfa1").Select
Range("A2:F65536").ClearContents
Application.ScreenUpdating = False
For Each f1 In fc
    s = f1.Name
    If Dir(ThisWorkbook.Path & "\" & s & "\" & ComboBox1.Value & ".xls") <> "" Then
        sat = Cells(65536, "B").End(xlUp).Row + 1
        conn.Open "Provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\" & s & "\" & ComboBox1.Value & ".xls;extended properties=""excel 8.0;hdr=No"""
        rs.Open ("Select * from [sayım$B2:F65536];"), conn, adOpenKeyset, adLockReadOnly
        Range("B" & sat).CopyFromRecordset rs
        rs.Close
        conn.Close
End If
Next
sat = Cells(65536, "B").End(xlUp).Row
For i = 2 To Cells(65536, "B").End(xlUp).Row
    Cells(i, "A").Value = i - 1
Next
Application.ScreenUpdating = True
MsgBox "İşlem tamadır." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"

End Sub

 

[unalh]

Evren hocam çok teşekkür ederim.

Dosya tam istediğimgibi olmuş.

Hayırlı akşamlar.

 

[Orion1]

Evren hocam çok teşekkür ederim.

Dosya tam istediğimgibi olmuş.

Hayırlı akşamlar.

Rica ederim.
İyi akşamlar.