Başka klasörde bulunan dosyaların sayfalarından veri almak

[numan şamil]

Herkese selamlar
Arkadaşlar bir klosör içerisinde 3 adet dosyam var. (ekte A dosyası formatında)ve her dosyada yaklaşık 70 adet (değişken arta biliyor) sayfa mevcut bu sayfalardan raporlama adlı dosyadaki sayfalara ayrı ayrı verileri almak istiyorum (veri alınacak klosörü ben seçmeliyim)
Fakat veri alacağım dosyalardaki tüm sayfaların dan değilde "ilk ve son sayfa "adlı sayfalar arasında bulunan sayfalardan veriyi almak istiyorum.
1) veri alınacak 3 dosyanın formatı ekteki A dosyasıyla bire bir aynı ve aynı hücrelerdeki veriler alınacak ve raporlama adlı dosyanın 1.sayfasına aktarılacak nasıl aktarılacağı ve hangi hücrelerin ne şekilde aktarılacağı ekteki dosyalarda sarı ile boyalı ve açıklama var.
2) veri alınacak 3 dosyadada ekteki A dosyası gibi ilk ve son sayfa isimleri olan sayfalar mevcut
3) veri alınacak hücrelerde bazıları metin bazılarında sayısal değerler ve formüller mevcut
4) veri alınacak dosyaların sayfaları sayfa korumalıdır
5) verileri alırken sadece hücrede yazılı olan metin ve sayısal değerlerin alınmasını istiyorum formüllerin alınmaması gerekiyor
Böyle birşey olabilirmi? bu yapılabilinirmi?

 

[numan şamil]

soru güncellendi

 

[numan şamil]

Olmayacak bir şeymi istedim?

 

[numan şamil]

bu konuda bir fikri olan arkadaşlar varmı?

 

[numan şamil]

mesaj 1deki soru ve ekli dosya güncellendi

 

[numan şamil]

Arkadaşlar
Aynı dosyadaki sayfalardan verileri sağolsun Korhan hocamın yardımı ile çözdüm fakat farklı klosördeki verileri 1. nolu mesajda belirttiğim şartlarda fakat ekli dosyayı güncelleyip (değiştirip) ekte gönderdiğim dosyada belirttiğim gibi verileri nasıl alabilirim bu konuda yardımlarınızı bekliyorum?

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub TÜM_VERİLERİ_AL()
    Dim Klasör As Object, Veri_Dosyası As Workbook, SR As Worksheet, Dosya_Yolu As String
    Dim Satır As Long, Dosya As Object, Kaynak_Dosya As Object, Sayfa As Worksheet
 
    On Error GoTo Son
 
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
 
    If Klasör Is Nothing Then
        MsgBox "Klasör seçimi yapmadığınız için işlemini iptal edilmiştir.", vbCritical
        Exit Sub
    End If
 
    Application.ScreenUpdating = False
 
    Dosya_Yolu = Klasör.Items.Item.Path
 
    If CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files.Count = 0 Then GoTo Son
 
 
    Set Veri_Dosyası = ThisWorkbook
    Set SR = Veri_Dosyası.Sheets("Sayfa 4")
 
    Veri_Dosyası.Sheets("Sayfa 4").Range("A2:G" & Rows.Count).ClearContents
 
    Satır = 2
 
    For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
        If Dosya.Name <> Veri_Dosyası.Name Then
            Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
 
            For Each Sayfa In Kaynak_Dosya.Worksheets
                If Sayfa.Index > Kaynak_Dosya.Sheets("ilk sayfa").Index And _
                Sayfa.Index < Kaynak_Dosya.Sheets("son sayfa").Index Then
                    SR.Cells(Satır, 1) = Sayfa.Range("H2")
                    SR.Cells(Satır, 2) = Sayfa.Range("B2")
                    SR.Cells(Satır, 3) = Sayfa.Range("C8")
                    SR.Cells(Satır, 4) = Sayfa.Range("D8")
                    SR.Cells(Satır, 5) = Sayfa.Range("E8")
                    SR.Cells(Satır, 6) = Sayfa.Range("F8")
                    SR.Cells(Satır, 7) = Sayfa.Range("J6")
                    Satır = Satır + 1
                End If
            Next
 
            Kaynak_Dosya.Close True
        End If
    Next
 
    Set Klasör = Nothing
    Set Veri_Dosyası = Nothing
    Set SR = Nothing
    Set Kaynak_Dosya = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Exit Sub
 
Son:
    If Not Kaynak_Dosya Is Nothing Then Kaynak_Dosya.Close True
    Application.ScreenUpdating = True
    MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub

 

[numan şamil]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub TÜM_VERİLERİ_AL()
    Dim Klasör As Object, Veri_Dosyası As Workbook, SR As Worksheet, Dosya_Yolu As String
    Dim Satır As Long, Dosya As Object, Kaynak_Dosya As Object, Sayfa As Worksheet
 
    On Error GoTo Son
 
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
 
    If Klasör Is Nothing Then
        MsgBox "Klasör seçimi yapmadığınız için işlemini iptal edilmiştir.", vbCritical
        Exit Sub
    End If
 
    Application.ScreenUpdating = False
 
    Set Veri_Dosyası = ThisWorkbook
    Set SR = Veri_Dosyası.Sheets("Sayfa 4")
 
    Dosya_Yolu = Klasör.Items.Item.Path
 
    If CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files.Count = 0 Then GoTo Son
 
    Veri_Dosyası.Sheets("Sayfa 4").Range("A2:G" & Rows.Count).ClearContents
 
    Satır = 2
 
    For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
        If Dosya.Name <> Veri_Dosyası.Name Then
            Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
 
            For Each Sayfa In Kaynak_Dosya.Worksheets
                If Sayfa.Index > Kaynak_Dosya.Sheets("ilk sayfa").Index And _
                Sayfa.Index < Kaynak_Dosya.Sheets("son sayfa").Index Then
                    SR.Cells(Satır, 1) = Sayfa.Range("H2")
                    SR.Cells(Satır, 2) = Sayfa.Range("B2")
                    SR.Cells(Satır, 3) = Sayfa.Range("C8")
                    SR.Cells(Satır, 4) = Sayfa.Range("D8")
                    SR.Cells(Satır, 5) = Sayfa.Range("E8")
                    SR.Cells(Satır, 6) = Sayfa.Range("F8")
                    SR.Cells(Satır, 7) = Sayfa.Range("J6")
                    Satır = Satır + 1
                End If
            Next
 
            Kaynak_Dosya.Close True
        End If
    Next
 
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Exit Sub
 
Son:
    Kaynak_Dosya.Close True
    Application.ScreenUpdating = True
    MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub

Merhaba Korhan bey
"Kaynak_Dosya.Close True "Hata veriyor ?

 

[Korhan Ayhan]

Selamlar,

Üstteki mesajımdaki koda küçük eklemeler yaptım. İncelermisiniz.

 

[numan şamil]

SELAMLAR
Dosya bulunamamıştır mesajı geliyor ?

 

[numan şamil]

Selamlar korhan bey
Hata benden kaynaklanıyormuş uygulama yaptığım dosyadaki sayfa ismi Sayfa4 bitişik yazılmış örnek dosyamda ise sayfa 4 şeklinde olduğu için kodlarda sayfa 4 şeklinde olduğundan dosya bulunamadı uyarısı veriyormuş bunu atladığım için özür dilerim.
Hocam yeri gelmişken müsadenizle bir soru daha sormak istiyorum
Örn:ilkve son sayfa değilde sayfalar içerisinde ali, veli, selami adlı sayfaları olduğu gibi kopyalayıp ahmet,mehmet,hasan isimli sayfalara yapıştırmak istersek (yalnız kopyalıyacağımız sutun genişlikleri ,hücre formatları kopyalanan sayfaların formatında olacak)kodlarda ne gibi bir düzenleme gerekmektedir?