• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

klasör içindeki dosyalardan data çekmek.

Rainbows

Rainbows

Katılım
5 Şubat 2009
Mesajlar
188
Excel Vers. ve Dili
Microsoft Office 365
Merhabalar,

c:\test klasörü icinde klasörler var bu klasörlerdede excel dosyaları var. bu excel dosyalarının "Masraf Aktarım Listesi" sheetindeki datayı cekmek istiyorum. ayrıntılı acıklamayı örnek dosyamda ekledim. sitede araştırdım fakat istedigim şekilde bulamadım.


http://www.dosyaupload.com/d3bY
 
Arkadaşlar yardımcı olabilecek bir arkadaş yokmudur?
 
Dener misiniz?

http://www.dosyaupload.com/4F1o

Kod: 
Sub verigetir()
    Set con = CreateObject("Adodb.connection"): Set rs = CreateObject("Adodb.recordset")
    dosyayolu = Range("B1").Value
    Range("A3:AZ65536").ClearContents
    On Error GoTo mesaj
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.Path & "\" & "New folder" & "\" & dosyayolu & ".xlsm" & ";extended properties=""excel 12.0;hdr=yes;"""


    sorgu = "SELECT * FROM [Masraf Aktarým Listesi$]"
    rs.Open sorgu, con, 1, 1
    Range("a3").CopyFromRecordset rs
    rs.Close: con.Close
    MsgBox "Ýþlem tamam"
     Set con = Nothing: Set rs = Nothing
 Exit Sub
mesaj:
 MsgBox "Yok aranan"
    

End Sub
 
Selamlar,

denedim sadece 1 dosyadaki datayı getirdi.
 
FERAZ' Alıntı:
Dener misiniz?

http://www.dosyaupload.com/4F1o

Kod: 
Sub verigetir()
    Set con = CreateObject("Adodb.connection"): Set rs = CreateObject("Adodb.recordset")
    dosyayolu = Range("B1").Value
    Range("A3:AZ65536").ClearContents
    On Error GoTo mesaj
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.Path & "\" & "New folder" & "\" & dosyayolu & ".xlsm" & ";extended properties=""excel 12.0;hdr=yes;"""


    sorgu = "SELECT * FROM [Masraf Aktarým Listesi$]"
    rs.Open sorgu, con, 1, 1
    Range("a3").CopyFromRecordset rs
    rs.Close: con.Close
    MsgBox "Ýþlem tamam"
     Set con = Nothing: Set rs = Nothing
 Exit Sub
mesaj:
 MsgBox "Yok aranan"
    

End Sub
Genişletmek için tıkla ...

sanırım siz burda sadece "new folder" klasörü icin bir ayrıcalık belirtmişsiniz. benim için test klasürü icindeki klasörleri isimleri önemli degil bu isimler her zaman degişebilir. yani test klasörünün icindeki bütün klasörler icin istiyorum ben aslında.
 
Akşam hallederim çmzüm gelmezse.
Ustalar halleder akşama kadar.
 
Kodları aşağıdaki şekilde revize edin.
Kod: 
Sub verigetir()
Dim Yol As String, Dosya As String
Dim K2 As Workbook
On Error Resume Next
 Range("A3:AZ65536").ClearContents
 x = 3
Yol = ThisWorkbook.Path & "\New folder\"
Dosya = Dir(Yol & "*.xls")
Do While Len(Dosya) > 0
    If ThisWorkbook.Name <> Dosya Then
        Workbooks.Open Filename:=Dosya
        
    Set con = CreateObject("Adodb.connection"): Set rs = CreateObject("Adodb.recordset")
    dosyayolu = Range("B1").Value
   
'    On Error GoTo mesaj
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    Yol & Dosya & ";extended properties=""excel 12.0;hdr=yes;"""


    sorgu = "SELECT * FROM [Masraf Aktarım Listesi$]"
    rs.Open sorgu, con, 1, 1
   
    Cells(x, "A").CopyFromRecordset rs
    x = x + 1
    rs.Close: con.Close
   
' Exit Sub
'mesaj:
' MsgBox "Yok aranan"
   End If
    
    Dosya = Dir()
    
Loop
    
 MsgBox "İşlem tamam"
     Set con = Nothing: Set rs = Nothing
End Sub
 
askm' Alıntı:
Kodları aşağıdaki şekilde revize edin.
Kod: 
Sub verigetir()
Dim Yol As String, Dosya As String
Dim K2 As Workbook
On Error Resume Next
 Range("A3:AZ65536").ClearContents
 x = 3
Yol = ThisWorkbook.Path & "\New folder\"
Dosya = Dir(Yol & "*.xls")
Do While Len(Dosya) > 0
    If ThisWorkbook.Name <> Dosya Then
        Workbooks.Open Filename:=Dosya
        
    Set con = CreateObject("Adodb.connection"): Set rs = CreateObject("Adodb.recordset")
    dosyayolu = Range("B1").Value
   
'    On Error GoTo mesaj
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    Yol & Dosya & ";extended properties=""excel 12.0;hdr=yes;"""


    sorgu = "SELECT * FROM [Masraf Aktarım Listesi$]"
    rs.Open sorgu, con, 1, 1
   
    Cells(x, "A").CopyFromRecordset rs
    x = x + 1
    rs.Close: con.Close
   
' Exit Sub
'mesaj:
' MsgBox "Yok aranan"
   End If
    
    Dosya = Dir()
    
Loop
    
 MsgBox "İşlem tamam"
     Set con = Nothing: Set rs = Nothing
End Sub
Genişletmek için tıkla ...

birde klasörlerin isimleri önemli degil. new folder olarak bakmayın yani klasörlerin isimleri farklı olabilir. x y bir klasörün icinde örnegin c:\test klasöründe bulunan klasörler olarak düsünün. test klasöründeki bütün dosyların içindeki excellere bakmasını istiyorum.
 
Kod: 
Sub verigetir()

Dim con, rs As Object, sorgu As String

Set con = CreateObject("Adodb.connection"): Set rs = CreateObject("Adodb.recordset")
'On Error Resume Next
With ThisWorkbook.Sheets("Masraf Aktarým Listesi")
    .Range("A3:AZ65536").ClearContents
'    For Each klasor In CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).SubFolders
    For Each klasor In CreateObject("Scripting.FileSystemObject").GetFolder("C:\test").SubFolders
        dosya = klasor.Path & "\" & .Range("B1").Value & ".xlsm"
        
    If Dir(dosya) <> "" Then 'Dosya varsa klasörde
        con.Open "provider=microsoft.ace.oledb.12.0;data source=" & dosya & ";extended properties=""excel 12.0;hdr=yes;"""
        sorgu = "SELECT * FROM [Masraf Aktarým Listesi$]"
        rs.Open sorgu, con, 1, 1
        .Range("a" & .Range("A65536").End(3)(2, 1).Row).CopyFromRecordset rs
        
        con.Close
    End If
    
    Next

End With

Set con = Nothing: Set rs = Nothing
      
   
End Sub
 
Son düzenleme:
Kod: 
Sub verigetir()

Dim con, rs As Object, sorgu As String

Set con = CreateObject("Adodb.connection"): Set rs = CreateObject("Adodb.recordset")
'On Error Resume Next
With ThisWorkbook.Sheets("Masraf Aktarým Listesi")
    .Range("A3:AZ65536").ClearContents
'    For Each klasor In CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).SubFolders
    For Each klasor In CreateObject("Scripting.FileSystemObject").GetFolder("C:\test").SubFolders
        dosya = klasor.Path & "\" & .Range("B1").Value & ".xlsm"
        
    If Dir(dosya) <> "" Then 'Dosya varsa klasörde
        con.Open "provider=microsoft.ace.oledb.12.0;data source=" & dosya & ";extended properties=""excel 12.0;hdr=yes;"""
        sorgu = "SELECT * FROM [Masraf Aktarým Listesi$]"
        rs.Open sorgu, con, 1, 1
        .Range("a" & .Range("A65536").End(3)(2, 1).Row).CopyFromRecordset rs
        
        con.Close
    End If
    
    Next

End With

Set con = Nothing: Set rs = Nothing
      
   
End Sub
 
Son düzenleme:
For Each klasor In CreateObject("Scripting.FileSystemObject").GetFolder("C:\test").SubFolders
Son yolladığım dosyayı(test) c sürücüsüne atınız.Yukarıda kod c için.

Alttakine göre dosya nerdeyse orda çalışır.

For Each klasor In CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).SubFolders
 
tamamdır çok teşekkürler. ellerinize saglık.
 
Alttaki kodda Ado suz yapıldı.

Kod: 
Sub verigetir()

Dim con, rs As Object, sorgu As String

Application.ScreenUpdating = False
Set con = CreateObject("Adodb.connection"): Set rs = CreateObject("Adodb.recordset")

With Workbooks("Tool.xlsm").Sheets("Masraf Aktarým Listesi")
    .Range("A3:M" & Rows.Count).ClearContents
'    For Each klasor In CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).SubFolders
    For Each klasor In CreateObject("Scripting.FileSystemObject").GetFolder("C:\test").SubFolders
        dosya = klasor.Path & "\" & .Range("B1").Value & ".xlsm"
 If Dir(dosya) <> "" Then
      Workbooks.Open dosya
      Windows(.Range("B1").Value & ".xlsm").Activate
      Range("A2:M" & Range("A" & Rows.Count).End(3).Row).Copy
       Workbooks("Tool.xlsm").Activate
      Range("A" & Range("A" & Rows.Count).End(3)(2, 1).Row).PasteSpecial xlPasteValues
      Application.CutCopyMode = False
      Windows(Range("B1").Value).Activate
      ActiveWorkbook.Close False

End If
    Next

End With

  Application.ScreenUpdating = True
   
End Sub
 
Son defa ado ile dosya varsa şartı eklendi kolay gelsin.

Kod: 
Sub verigetir()

Dim con, rs As Object, sorgu As String

Set con = CreateObject("Adodb.connection"): Set rs = CreateObject("Adodb.recordset")
'On Error Resume Next
With ThisWorkbook.Sheets("Masraf Aktarým Listesi")
    .Range("A3:AZ65536").ClearContents
'    For Each klasor In CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).SubFolders
    For Each klasor In CreateObject("Scripting.FileSystemObject").GetFolder("C:\test").SubFolders
        dosya = klasor.Path & "\" & .Range("B1").Value & ".xlsm"
        
    If Dir(dosya) <> "" Then 'Dosya varsa klasörde
        con.Open "provider=microsoft.ace.oledb.12.0;data source=" & dosya & ";extended properties=""excel 12.0;hdr=yes;"""
        sorgu = "SELECT * FROM [Masraf Aktarým Listesi$]"
        rs.Open sorgu, con, 1, 1
        .Range("a" & .Range("A65536").End(3)(2, 1).Row).CopyFromRecordset rs
        
        con.Close
    End If
    
    Next

End With

Set con = Nothing: Set rs = Nothing
      
   
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst