Klasör içindeki excel dosyalarının sayfalarından belirtilen hücre değerlerini almak

[tahsinanarat]

Sub listele()
Set s1 = Sheets("Arsiv")
For a = 1 To Sheets.Count
If Sheets(a).Name <> "anket" And Sheets(a).Name <> "Arsiv" Then
s1.Cells(a + 1, "a") = Sheets(a).[D1]
s1.Cells(a + 1, "b") = Sheets(a).[D2]
s1.Cells(a + 1, "c") = Sheets(a).[D3]
s1.Cells(a + 1, "d") = Sheets(a).[D4]
s1.Cells(a + 1, "e") = Sheets(a).[S2]
s1.Cells(a + 1, "f") = Sheets(a).[S3]
s1.Cells(a + 1, "G") = Sheets(a).[S4]
s1.Cells(a + 1, "H") = Sheets(a).[S5]
End If
Next
End Sub

Yukarıdaki kod ile aynı çalışma kitabının sayfalarından belirtilen hücre değerlerini listeliyebiliyorum.
Ben Aynı klasör içindeki farklı isimlerdeki çalışma kitaplarının sayfalarından (sayfalar aynı formatda) belirttiğim hücre değerlerini listelemek istiyorum.
Kodda nasıl bir değişiklik yapmalıyım. Teşekkürler

 

[ÖmerFaruk]

"Aynı klasör içindeki farklı isimlerdeki çalışma kitaplarının"
ifadesinde belirttiğiniz çalışma kitapları
Klasör altındaki tüm çalışma kitapları mı yoksa isimleri belli olan bazı çalışma kitapları mı?
Eğer bazı kitaplar ise bunların isimleri nerede yazıyor?

 

[tahsinanarat]

Sn. ÖmerFaruk Bey; klasördeki farklı isimlerdeki çalışma kitaplarının farkı olan tüm sayfalarından (sayfaların formatları aynı)
belirtilen hücre değerlerini listelemek istiyorum. İlginiz için teşekkür ederim.

 

[ÖmerFaruk]

Klasörünüz altında 1 sizin dosyanız + 99 farklı dosya var diyelim
1. Bu 99 farklı dosyanın tamamından mı? Yoksa bazılarından mı?
2. Bu 99 dosyanın ya da bazı dosyaların, adı Anket ya da Arşiv olmayan tüm çalışma sayfalarındaki D1-D4 ve S2-S5 hücreleri mi?

 

[tahsinanarat]

Sn. ÖmerFaruk Bey; bu Arşiv ve Anket sekmeleri Çalıştığım (datalarını aldığım) kitabında olduğundan bu sayfaları ayrı tutması için belirtmiştim, Kalasörde bu dosyalar olmayacak, yani Klasördeki Tüm Çalışma Kitaplarından alacak diyebilirim. Teşekkürler.

 

[ÖmerFaruk]

Klasördeki Tüm Çalışma Kitaplarından alacak diyebilirim. OK

Bu kitaplardan alıncak verilerin bulunduğu sayfa adları nedir?

 

[tahsinanarat]

Sayfa isimleri degişken

 

[ÖmerFaruk]

Hacı abim. Kodu yazdırmamak için direniyorsun gibi bir durum ortaya çıkıyor.
Neyi nerden alacağımızı bilmeden nasıl yardımcı olacağım sana.

Tüm çalışma kitaplarından çekilecek veriler, o çalışma kitaplarının hangi sayflarında ? tüm sayfalardan mı?
Soru gayet açık

 

[tahsinanarat]

Faruk bey tüm sayfalardan ve tüm sayfa isimleri farklı.

 

[tahsinanarat]

Klasörünüz altında 1 sizin dosyanız + 99 farklı dosya var diyelim
1. Bu 99 farklı dosyanın tamamından mı? Yoksa bazılarından mı?
2. Bu 99 dosyanın ya da bazı dosyaların, adı Anket ya da Arşiv olmayan tüm çalışma sayfalarındaki D1-D4 ve S2-S5 hücreleri mi?

Bu çalışma kitaplarında Anket adlı sekme hariç tutulacak.

 

[ÖmerFaruk]

Dört soruda ancak cevap alabildim. Teşekkürler.
Özelden yazdığınız isteğe bakmadan bu kodları yazdım

Sub KapalıDosyaVerileri()
Dim xFiles As Object, xDosya As Variant, xZaman As Double, xYol As String
Dim Sayfa As Worksheet, a As Byte

    xZaman = Timer
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    xYol = ThisWorkbook.Path
    Set xFiles = CreateObject("Scripting.FileSystemObject").GetFolder(xYol).Files
   
    For Each xDosya In xFiles
        If xDosya = ThisWorkbook.FullName Or InStr(1, xDosya, "$") <> 0 Then GoTo Devam
        Workbooks.Open (xDosya)
        For Each Sayfa In Workbooks(xDosya.Name).Worksheets
            If Sayfa.Name <> "Anket" Then
                a = a + 1
                Workbooks(xDosya.Name).Sheets(Sayfa.Name).Range("D1:D4").Copy
                ThisWorkbook.Activate
                Sheets("Arsiv").Range("A" & a).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                Workbooks(xDosya.Name).Sheets(Sayfa.Name).Range("S2:S5").Copy
                Sheets("Arsiv").Range("E" & a).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            End If
        Next Sayfa
        Workbooks(xDosya.Name).Close
Devam:
    Next
   
    Set xFiles = Nothing
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[tahsinanarat]

Sn. ÖmerFaruk Bey çok teşekkür ediyorum, sizi biraz yordum hakkınızı helal edin. Elinize sağlık.