Kapalı dosyalardan veri alma

[sward175]

Herkese Merhabalar,

Yapmak istediğimi şöyle dile getiriyorum.
Bir klasör içinde günün tarihi adında ( Örnek Dosya içinde ) dosyalar var.
Tüm dosyaların Giriş sayfasının F2 hücresinde günün tarihi,
B39:B42 aralığında Tank No, Sabit
H39:H42 aralığında ( 3 haneli ) sayı Örnek 188,203,178,233 gibi değişken rakamlar bulunmakta.
Aynı Klasör içine Özet isimli bir sayfa açıp bu bilgileri bir sayfada ekteki gibi listelemek istiyorum.

Saygılarımla,


sward175

 

[Erdem Akdemir]

Merhaba,

Örnek dosyaların sayfa adı'da önemli.
Örnek dosyaları ayrı ayrı ekleyebilir misiniz?

 

[sward175]

Sayın, kuvari,
öncelikli ilginize teşekkür ederim.

Dosya isimleri aşağıdaki gibi fakat tarih oldukları için bir sonraki ayda değişmesi gerekiyor.

Stok 01.11.2015.xlsm
Stok 02.11.2015.xlsm
Stok 03.11.2015.xlsm
Stok 04.11.2015.xlsm
Stok 05.11.2015.xlsm
Stok 06.11.2015.xlsm
Stok 07.11.2015.xlsm
Stok 08.11.2015.xlsm
Stok 09.11.2015.xlsm
Stok 10.11.2015.xlsm
Stok 11.11.2015.xlsm
Stok 12.11.2015.xlsm
Stok 13.11.2015.xlsm
Stok 14.11.2015.xlsm
Stok 15.11.2015.xlsm
Stok 16.11.2015.xlsm
Stok 17.11.2015.xlsm
Stok 18.11.2015.xlsm
Stok 19.11.2015.xlsm
Stok 20.11.2015.xlsm
Stok 21.11.2015.xlsm
Stok 22.11.2015.xlsm
Stok 23.11.2015.xlsm
Stok 24.11.2015.xlsm
Stok 25.11.2015.xlsm
Stok 26.11.2015.xlsm
Stok 27.11.2015.xlsm
Stok 28.11.2015.xlsm
Stok 29.11.2015.xlsm
Stok 30.11.2015.xlsm

 

[Erdem Akdemir]

Dosya isimleri tamam. Veri alınacak sayfanın ismi nedir.

 

[sward175]

kuvari Bey Merhaba,

Hepsinin içinde birden fazla sayfa var ama sadece " Giriş " sayfasından bilgiler alınacak.
saygı ve sevgi ile,

 

[Erdem Akdemir]

Merhaba,

Tag'daki kodu dener misiniz?

Sub deneme()

Range("a2:e" & Rows.Count).ClearContents
Set con = VBA.CreateObject("adodb.Connection")
Set klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Klasör seçiniz !", 12)
Set fso = VBA.CreateObject("scripting.filesystemobject")

For Each dosya In fso.getfolder(klasor.self.Path).Files
If Dir(klasor.self.Path & "\" & dosya.Name, vbNormal) = "" Then GoTo 10

ad = fso.GetExtensionName(dosya)
If ad = "xlsx" Or ad = "xls" Then

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
dosya & ";extended properties=""Excel 12.0;hdr=no"""

sorgu = "select * from [Giriş$F2:F2]"

Set rs = con.Execute(sorgu)
son = Cells(Rows.Count, "A").End(3).Row + 1
Range("A" & son).CopyFromRecordset rs

Set rs = Nothing

sorgu = "select * from [Giriş$H39:H42]"
Set rs = con.Execute(sorgu)
a = rs.getrows

Range("B" & son).Resize(, 4) = a

End If

con.Close
Set rs = Nothing

10 Next
End Sub

 

[sward175]

sayın, kuvari, merhaba,
Kodu uygulamaya çalıştım fakat başarılı olamadım. Klasörü sıkıştırıp göndermeye niyetlendim fakat pc de program yok. Sizce çözüm ne olabilir.

Saygılarımla,

 

[Erdem Akdemir]

dosyalarınız anlattığınız gibiyse olması lazım.

ekteki klasörü masa üstünde açın, daha sonra kodu çalıştırın olacaktır.