Kapalı dosyadaki verileri listeleme.

[Bora K]

Kapalı excel dosyalarındaki verileri listeleme.

Merhabalar.

Klasör içinde dosyaların tamamında "Data" adlı sayfalar var.
"Data" Sayfalarının D sütunundaki verileri
Çalışma sayfasında liste halinde görmek istiyorum. Listenin en tepesine ise
ilgili dosyanın adı yazılacak. Konuya hakim değerli uzmanlarımızdan yardım bekliyorum.

Saygılarımla.

 

[Orion1]

Dosyanız ektedir.

Sub veri59()
Dim conn As Object, rs As Object, dosya As String
Dim sut As Integer
Sheets("Liste").Select
sut = Cells(2, 256).End(xlToLeft).Column
Range(Cells(2, 3), Cells(2, sut)).ClearContents
dosya = Dir(ThisWorkbook.Path & "\Esnaflar\*.xls")
sut = 3
Set conn = CreateObject("Adodb.connection")
Set rs = CreateObject("adodb.recordset")
Application.ScreenUpdating = False
Do While dosya <> ""
    Cells(2, sut).Value = Left(dosya, Len(dosya) - 4)
    conn.Open ("provider=microsoft.jet.oledb.4.0;data source=" & _
        ThisWorkbook.Path & "\Esnaflar\" & dosya & _
        ";extended properties=""excel 8.0;hdr=no;imex=1""")
        rs.Open "select * from [Data$D3:D65536];", conn, 1, 1
        Cells(4, sut).CopyFromRecordset rs
        rs.Close
        conn.Close
    sut = sut + 1
    dosya = Dir
Loop
Set rs = Nothing
Set conn = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlanmıştır." & vbLf & "evrengizle@hotmail.com", _
    vbOKOnly + vbInformation, Application.UserName
End Sub

 

[Bora K]

Merhaba Evren Hocam.
Alakanız için çok teşekkür ederiz.

Makromuz şu hali kusursuz vede çok hızlı.
Dosya yolunu manuel olarak (Açılır pencerede) kendimiz seçersek
kod daha bir işlevsel olacak bizim açımızdan.
Bu mümkünmü acaba?

 

[Orion1]

Merhaba Evren Hocam.
Alakanız için çok teşekkür ederiz.

Makromuz şu hali kusursuz vede çok hızlı.
Dosya yolunu manuel olarak (Açılır pencerede) kendimiz seçersek
kod daha bir işlevsel olacak bizim açımızdan.
Bu mümkünmü acaba?

Dosyanız ektedir.

Sub veri59()
Dim conn As Object, rs As Object, dosya As String
Dim sut As Integer
Sheets("Liste").Select
sut = Cells(2, 256).End(xlToLeft).Column
Range(Cells(2, 3), Cells(2, sut)).ClearContents
'dosya = Dir(ThisWorkbook.Path & "\Esnaflar\*.xls")
klsr = klasor()
sut = 3
Set conn = CreateObject("Adodb.connection")
Set rs = CreateObject("adodb.recordset")
Application.ScreenUpdating = False
dosya = Dir(klsr & "\*.xls")
Do While dosya <> ""
    Cells(2, sut).Value = Left(dosya, Len(dosya) - 4)
    conn.Open ("provider=microsoft.jet.oledb.4.0;data source=" & _
        klsr & "\" & dosya & ";extended properties=""excel 8.0;hdr=no;imex=1""")
        rs.Open "select * from [Data$D3:D65536];", conn, 1, 1
        Cells(4, sut).CopyFromRecordset rs
        rs.Close
        conn.Close
    sut = sut + 1
    dosya = Dir
Loop
Set rs = Nothing
Set conn = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlanmıştır." & vbLf & "evrengizle@hotmail.com", _
    vbOKOnly + vbInformation, Application.UserName
End Sub

 

[Bora K]

Çok çok teşekkür ederim
Evren Hocam.
Rabbim yar ve yardımcınız olsun inşallah.

Saygılarımla.