Kapalı dosyalardan belirlenmiş bölümleri alma

[Tevfik_Kursun]

Merhaba Arkadaşlar,
Birbirine özdeş ikişer sayfalık, (sayfalarındaki satır sayıları farklı) açık dosyalardan Y12 hücresinde belirtilen bölgeleri peş peşe iki farklı sayfada toplamak için hazırladığım makro çok güzel çalışıyor. Ana dosyada Y13 hücresi getirilen değerlerin nereye yapıştırılacağını belirtiyor.

Option Explicit

Sub Tek_Dosya_Yap()
    Dim x As Integer
    Dim Say1, Say2 As String
    Application.WindowState = xlNormal
    For x = 1 To 5
        Windows("2020_0" & x & ".xlsm").Activate
        Sheets("Sayfa1").Activate
        ActiveSheet.Unprotect "111"
        If [A1] = 0 Then GoTo Say1
        Range([Y12].Text).Select
        Selection.Copy
        Windows("2020_2.xlsm").Activate
        Sheets("Sayfa1").Activate
        Range([Y13].Text).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
Say1:
        Windows("2020_0" & x & ".xlsm").Activate
        Sheets("Sayfa2").Activate
        ActiveSheet.Unprotect "111"
        If [A1] = 0 Then GoTo Say2
        Range([Y12].Text).Select
        Selection.Copy
        Windows("2020_2.xlsm").Activate
        Sheets("Sayfa2").Activate
        Range([Y13].Text).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
Say2:
    Next x
End Sub

Bilgi alınan dosyalar kapalı olsa bu makro nasıl değişir? (Sitede bulduğum örnekleri adapte edemedim.)
Saygılarımla

 

[Korhan Ayhan]

Örnek dosyalarınızı paylaşınız.

 

[Tevfik_Kursun]

Sayın Korhan Hocam,
Buyrun (isimler - rumuzlar gerçek değil)
Saygılarımla

 

[Korhan Ayhan]

Sayfalarda Y12 hücrelerinde;

A2:E1 ve A2:G1 yazıyor.

Burada bir gariplik yok mu?

 

[Tevfik_Kursun]

Sayın Korhan Hocam,
Bu dedikleriniz A2:E1 ve A2:G1 2020_2.xlsm de. Çünkü data yok. Bu alıcı dosya. Diğer dosyalar verici. Verici dosyalarda Y12 dataların bulunduğu bölgeyi belirtiyor. Ana dosyada ise Y13 kopyalamanın hangi hücreden başlaması gerektiğini gösteriyor.
Saygılarımla

 

[Korhan Ayhan]

İşin özünde kapalı dosyalarda ki tüm veri alınmayacak mı?

 

[Tevfik_Kursun]

Evet tüm veriler, Sayın Hocam

 

[Korhan Ayhan]

Deneyiniz.

Tüm dosyalarınız aynı klasörde olsun. Eğer farklı klasörde kullanmak isterseniz YOL tanımını isteğinize göre değiştirirsiniz.

Option Explicit

Sub Tek_Dosya_Yap()
    Dim Yol As String, Dosya As String, Baglanti As Object, Kayit_Seti As Object, Zaman As Double
    Dim K1 As Workbook, S1 As Worksheet, S2 As Worksheet, Sorgu As String, Satir As Long
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sayfa1")
    Set S2 = K1.Sheets("Sayfa2")
   
    S1.Range("A3:E" & S1.Rows.Count).ClearContents
    S2.Range("A3:G" & S2.Rows.Count).ClearContents
   
    Yol = ThisWorkbook.Path & "\"
   
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
   
    Dosya = Dir(Yol & "*.xl*")
   
    While Dosya <> ""
        If Dosya <> ThisWorkbook.Name Then
            Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
            Yol & Dosya & ";Extended Properties=""Excel 12.0;Hdr=Yes"""
           
            Sorgu = "Select * From [Sayfa1$A:E]"
               
            Kayit_Seti.Open Sorgu, Baglanti, 1, 1
               
            If Kayit_Seti.RecordCount > 0 Then
                Satir = S1.Cells(S1.Rows.Count, 1).End(3).Row + 1
                If Satir < 3 Then Satir = 3
                S1.Range("A" & Satir).CopyFromRecordset Kayit_Seti
            End If
       
            If Kayit_Seti.State = 1 Then Kayit_Seti.Close
               
            Sorgu = "Select * From [Sayfa2$A:G]"
               
            Kayit_Seti.Open Sorgu, Baglanti, 1, 1
               
            If Kayit_Seti.RecordCount > 0 Then
                Satir = S2.Cells(S2.Rows.Count, 1).End(3).Row + 1
                If Satir < 3 Then Satir = 3
                S2.Range("A" & Satir).CopyFromRecordset Kayit_Seti
            End If
        End If
       
        If Kayit_Seti.State = 1 Then Kayit_Seti.Close
        If Baglanti.State = 1 Then Baglanti.Close
       
        Dosya = Dir
    Wend
   
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    Set K1 = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[Tevfik_Kursun]

Sayın Korhan Hocam,
İlginize teşekkür ederim. Resimdeki hatalar geliyor.
Saygılarımla

 

[Tevfik_Kursun]

Sayın Korhan Hocam,
Tamam, ilginize çok teşekkür ederim. Düzgün çalıştı. Şimdi esas dosyama adapte edeceğim.
Saygılarımla