Birden Çok Kapalı Excel Dosyasından Veri Alma

[ergunarat]

Merhaba;
Bir klasör içerden aynı formatta yüzlerce excel dosyası vardır. Ekte 2 önek dosya ve bir toplu dosya mevcuttur. Amacım klasör içeresindeki excel dosyasının farklı iki sayfasından veri alarak tabloya işlemesi. Tek sayfa sıkıntı olmuyor ancak veriler iki sayfadan alındığı durumda aradaki bağlantıyı kuramadım.
Konu hakkında desteğinizi talep ederim.

 

[Murat OSMA]

Merhabalar,
Bu kodları kullanabilirsiniz;

[FONT="Trebuchet MS"]DefObj C-D, F, R: DefStr S-T, Y: DefInt I-J
Sub Emre()
    Set con = CreateObject("adodb.connection")
    Set rs = CreateObject("adodb.recordset")
    Set fso = CreateObject("Scripting.FileSystemObject")
    yol = ThisWorkbook.Path
    Range("A2:L65536").Clear
    For Each dosya In fso.getfolder(yol).Files
        If dosya.Name <> ThisWorkbook.Name And _
           Mid(dosya.Name, 2, 1) <> "$" Then
           con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
           dosya & ";extended properties=""Excel 12.0; hdr=no"""
           t = "select * from [sonuc$Y4:AA5]"
           rs.Open t, con, 1, 1
           Range("B65536").End(3)(2, 1).CopyFromRecordset rs
           rs.Close
           s = "select * from [ACIKLAMA$] where not isnull(f3)"
           rs.Open s, con, 1, 1
           If rs.RecordCount > 0 Then
            a = Range("A65536").End(3).Row + 1
            j = Range("D65536").End(3).Row + 1
            Range("a65536").End(3)(2, 1) = Replace(dosya.Name, ".xlsx", "")
            Cells(j, 3).CopyFromRecordset rs
            i = Range("D65536").End(3).Row
            Range("A65536").End(3).AutoFill Destination:=Range("A" & a & ":A" & i)
            Range("B65536").End(3).AutoFill Destination:=Range("B" & a & ":B" & i), Type:=xlFillCopy
           End If
           rs.Close: con.Close
        End If
    Next dosya
    i = Empty: j = Empty: s = "": t = "": y = "": Set dosya = Nothing
    Set rs = Nothing: Set fso = Nothing: Set con = Nothing
End Sub[/FONT]

Dosyalarınızı da ekliyorum.

 

[numan şamil]

Merhaba;
Bir klasör içerden aynı formatta yüzlerce excel dosyası vardır. Ekte 2 önek dosya ve bir toplu dosya mevcuttur. Amacım klasör içeresindeki excel dosyasının farklı iki sayfasından veri alarak tabloya işlemesi. Tek sayfa sıkıntı olmuyor ancak veriler iki sayfadan alındığı durumda nasıl yapılacağını bilmiyorum. Konu hakkında desteğinizi talep ederim.

Açıklama ve örnek uygulama ektedir.

Alternatif olsun
dosyalar ayrı klosörde olmak koşulu ile

Sub Aktar()
      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, st1, st2 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("Sayfa1")
    Dosya_Yolu = Klasör.Items.Item.Path
    If CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files.Count = 0 Then GoTo son
    
  SR.Range("A2:L" & 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)
            Set st1 = Kaynak_Dosya.Sheets("sonuc")
            Set st2 = Kaynak_Dosya.Sheets("ACIKLAMA")
               
                For Z = 3 To [b65500].End(3).Row
                  
                   If st2.Range("E" & Z) = 1 Then
                   SR.Range("A" & Satır) = st1.Range("j4")
                    SR.Range("B" & Satır) = st1.Range("y4")
                    SR.Range("C" & Satır) = st2.Range("A" & Z)
                    SR.Range("D" & Satır) = st2.Range("B" & Z)
                    SR.Range("E" & Satır) = st2.Range("C" & Z)
                    SR.Range("F" & Satır) = st2.Range("D" & Z)
                    SR.Range("G" & Satır) = st2.Range("E" & Z)
                    SR.Range("H" & Satır) = st2.Range("F" & Z)
                    SR.Range("I" & Satır) = st2.Range("G" & Z)
                    SR.Range("J" & Satır) = st2.Range("H" & Z)
                    SR.Range("K" & Satır) = st2.Range("I" & Z)
                    SR.Range("L" & Satır) = st2.Range("J" & Z)
                   Satır = Satır + 1
                   End If
                    Next Z
            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

 

[kelkitli]

Dostlar, çok güzel bir konu ama dosyaları forumdan indirme şansım yok. Mümknmü dosya paylaşımı?

 

[erdenek]

Dostlar, çok güzel bir konu ama dosyaları forumdan indirme şansım yok. Mümknmü dosya paylaşımı?

buyur Sayın kelkitli;

http://www.dosya.tc/server26/UAzgbF/ADOileKapal_DosyalardanVeriAlma.rar.html

http://www.dosya.tc/server26/UAzgbF/_RNEK.rar.html

 

[kelkitli]

Teşekkür ederim Sn. erdenek.

 

[ergunarat]

Teşekkür ederim.