klasördeki .xls dosyalarının a1 hücrelerini yazdırmak

[seyehat25]

merhaba arkadarşlar...
örn: arşiv adlı klasördeki ".xls" dosyalrının "a1" hücrelerindeki değerlerini yeni açtığım "liste" adlı excel dosyasına alt alta sıralamak istiyorum acaba mümkün mü?bu sayede binlerce takip noya ulaşmış olacağım ve süzdüreceğim.yardımlarınınz için şimdiden çok teşekürler.
kolay gelsin.

 

[Orion1]

C:\ kök dizininde arşiv klasörü içinde bulunan xls uzantılı excel dosyalarının sayfa1 isimli syafalarındaki A1 hücrelerinde bulunan verileri a sütununa alt alta listeler.
Excel4 makrosu kullanılmıştır.
Aşağıdaki kodları boş bir standart modüle kopyalayıp çalıştırınız.

Sub Disverial()
Dim MyArg As String
Dim i As Long, dosya As String
Range("A:A").ClearContents
dosya = Dir("C:\arşiv\*.xls")
i = 1
Do While dosya <> ""
    MyArg = "'C:\arşiv\[" & dosya & "]Sayfa1'!R1"
    Cells(i, 1).Value = ExecuteExcel4Macro(MyArg & "C1")
    i = i + 1
    dosya = Dir
Loop
End Sub

 

[desk]

Peki üstad burda önce excel dosya ismini sonra G15 hücresini nasıl yazdırabiliriz. Klasörün içindeki tüm excel dosyalarının.

 

[desk]

Koddaki revize yardimi.



Sub Dosya_bilgileri()
Dim ds, dc, f, s
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder("C:\deneme")
Set dc = f.Files
For Each dosya In dc
c = c + 1
Cells(c, 1) = dosya.Name

Cells(c, 2) = ??? şu kısıma nasıl G15 hücrelerini yazdırabilirim.?

Next
End Sub

 

[desk]

Arkadaşlar biri yardım etsin çizmiş durumdayım. acil yardım.!!

 

[halit3]

bu olurmu
Cells(c, 2) = Range("G15").Value

 

[desk]

Sub Dosya_bilgileri()
Dim ds, dc, f, s
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder("C:\deneme")
Set dc = f.Files
For Each dosya In dc
c = c + 1
Cells(c, 1) = dosya.Name

Cells(c, 2) = Range("G15").Value

Next
End Sub

Sonuç vermedi? G15 hücresindeki bir formül sonucu ve sayı değerli. Acil yardım bir saattir uğraşıyorum..

 

[halit3]

örnek dosyanı gönder

 

[desk]

suz ile
c:\deneme deki excel dosyaları

excelvba.xls
excelvba2.xls
denemenin içi

 

[halit3]

Sub Dosya_İsimleri()
Dim ds, dc, f, s
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder("C:\deneme")
Set dc = f.Files
For Each dosya In dc
c = c + 1
Cells(c, 1) = dosya.Name
Cells(c, 2).Value = "='C:\deneme\[" & Cells(c, 1) & "]Sayfa1'!$G$15"Cells(c, 2).Value = Cells(c, 2).Value
Next
End Sub

 

[desk]

syntax error veriyor ?

 

[desk]

syntax error hatasını neden verir arkadaşlar bileniniz yokmu.

 

[halit3]

syntax error veriyor bu hata makronun bir satırı diğer satırıyla birleşmiş ve bu durumda tırnak işareti eksik geldiğinden verir sen aşağıdaki kodu kullan

Sub Dosya_İsimleri()
Dim ds, dc, f, s
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder("C:\deneme")
Set dc = f.Files
For Each dosya In dc
c = c + 1
Cells(c, 1) = dosya.Name
Cells(c, 2).Value = "='C:\deneme\[" & Cells(c, 1) & "]Sayfa1'!$G$15"
Cells(c, 2).Value = Cells(c, 2).Value
Next
End Sub

 

[desk]

deneme klasörünün alt klasörleride varsa ve bu alt klasörlerin içindede dosyalar varsa ne yapabilirim.?

 

[Korhan Ayhan]

Selamlar,

Hamit beyin aşağıdaki linkteki cevabını G15 hücresini alacak şekilde düzenledim. İncelermisiniz. Dosyalardaki sayfa adının "Sayfa1" olduğu varsayılmıştır. Sizdeki sayfa ismi farklı ise düzelterek kodu deneyiniz.

http://www.excel.web.tr/f48/klasorun-icindeki-tum-alt-klasor-ve-icindeki-dosyalar-t63870.html

Option Explicit
 
Sub Klasörden_Veri_Al()
    Dim Klasör As Object
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçiniz !", 1)
    [A2:B65536].ClearContents
    Liste (Klasör.Items.Item.Path)
    Alt_Liste (Klasör.Items.Item.Path)
    Set Klasör = Nothing
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Private Sub Liste(Yol As String)
    Dim Dosya As String, Satır As Long
 
    On Error Resume Next
    Dosya = Dir(Yol & "\*.xls")
    Satır = 1
    While Dosya <> ""
        DoEvents
        Satır = Satır + 1
        Cells(Satır, 1) = Yol & "\" & Dosya
        Cells(Satır, 2) = ExecuteExcel4Macro("'" & Yol & "\[" & Dosya & "]Sayfa1'!R15C7")
        Dosya = Dir
    Wend
End Sub
 
Private Sub Alt_Liste(Yol As String)
    Dim Alt_Klasör As Object, Alt_Dosya As Object, Dosya As String, Satır As Long
    Set Alt_Klasör = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).SubFolders
 
    On Error GoTo Devam
 
    For Each Alt_Dosya In Alt_Klasör
    Dosya = Dir(Alt_Dosya.Path & "\*.xls")
        While Dosya <> ""
        DoEvents
        Satır = [A65536].End(3).Row + 1
        Cells(Satır, 1) = Alt_Dosya.Path & "\" & Dosya
        Cells(Satır, 2) = ExecuteExcel4Macro("'" & Alt_Dosya.Path & "\[" & Dosya & "]Sayfa1'!R15C7")
        Dosya = Dir
        Wend
    Alt_Liste (Alt_Dosya.Path)
Devam:
    Next
    Set Alt_Klasör = Nothing
End Sub

 

[desk]

halit3 beye ve korhan beye sonsuz tşk ler.

 

[halit3]

sayın desk birde bu dosyaya bak klasörün içindeki xls uzantılı dosyaların adını ve al:j10 satırlarındaki verileri alıyor ancak veri alınan dosyaların içinde mutlaka Sayfa1 sayfası olması gerekiyor çünkü verileri Sayfa1 den alıyor