• DİKKAT

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

Kapalı Dosyadan Açık Dosyaya Veri Alma

S

schlecht

Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
İyi akşamlar, Kapal1, Kapalı2, Kapalı3 dosyalarıındaki A2:J2 arası verileri Açık dosya A2 den başlayarak alt alta buton yardımı ile kopyalamak istiyorum. Kapalı olan dosya sayısı değişken 50 - 80 arası dosya var. Dosya isimleri sabit değil ve bulunduğu klasör ismi sabit değil. Yardımlarınızı rica ederim.
 

Ekli dosyalar

Murat Hocanın yazdığı kod aşağıda

DefObj C, E-F, R
Sub Emre()
Set Rky = CreateObject("adodb.connection")
Set fso = CreateObject("scripting.filesystemobject")
For Each evn In fso.getfolder(ThisWorkbook.Path).Files
If Not evn.Name Like "*" & ThisWorkbook.Name Then
Rky.Open "Provider=Microsoft.ace.oledb.12.0;Data Source=" & _
evn & ";Extended Properties=""Excel 12.0;hdr=no"""
Set rs = Rky.Execute("Select * from [Sayfa1$]")
Range("A65536").End(3)(2, 1).CopyFromRecordset rs
rs.Close: Rky.Close
End If
Next evn
Set rs = Nothing: Set Rky = Nothing: sorgu = ""
Set fso = Nothing: Set evn = Nothing
End Sub

burdaki
Set rs = Rky.Execute("Select * from [Sayfa1$]")
satırında yer alan [Sayfa1$] değişken ise nasıl bir yol izlemem gerekir.

Benim kapalı olan yani dosyalarımda sayfa isimleri değişken Sayfa1 isimleri değişken (ocak, şubat, mart, ... ) gibi..
 
Kod: 
DefObj C, E-F, R
Sub Emre()
Set Rky = CreateObject("adodb.connection")
Set fso = CreateObject("scripting.filesystemobject")

For Each evn In fso.getfolder(ThisWorkbook.Path).Files
If Not evn.Name Like "*" & ThisWorkbook.Name Then
Rky.Open "Provider=Microsoft.ace.oledb.12.0;Data Source=" & _
evn & ";Extended Properties=""Excel 12.0;hdr=no"""
Set rs = Rky.Execute("Select * from [" & Sheets(1).Name & "$A2:J2]")
Range("A65536").End(3)(2, 1).CopyFromRecordset rs
rs.Close: Rky.Close
End If
Next evn
Set rs = Nothing: Set Rky = Nothing: sorgu = ""
Set fso = Nothing: Set evn = Nothing
End Sub
 
askm hocam eliniz sağlık teşekkürler. Şöyle bir sorunum var. Butona 2. kez bastığımda aynı veriler bir daha alt alta kopyalanıyor. Butona 2. basıldığında ilk basılmış gibi baştan kopyalama olabilir mi?
 
Kod: 
DefObj C, E-F, R
Sub Emre()
Set Rky = CreateObject("adodb.connection")
Set fso = CreateObject("scripting.filesystemobject")
Range("a2:j65535"). Clear
For Each evn In fso.getfolder(ThisWorkbook.Path).Files
If Not evn.Name Like "*" & ThisWorkbook.Name Then
Rky.Open "Provider=Microsoft.ace.oledb.12.0;Data Source=" & _
evn & ";Extended Properties=""Excel 12.0;hdr=no"""
Set rs = Rky.Execute("Select * from [" & Sheets(1).Name & "$A2:J2]")
Range("A65536").End(3)(2, 1).CopyFromRecordset rs
rs.Close: Rky.Close
End If
Next evn
Set rs = Nothing: Set Rky = Nothing: sorgu = ""
Set fso = Nothing: Set evn = Nothing
End Sub
 
Elinize sağlık, teşekkür ederim. Mükemmel çalışıyor.
 
Merhaba,

Bence kodun hata vermesi gerekiyor...

Sebebi ise Sheets(1).Name ifadesi aktif dosyadaki sayfa adına bakar.
 
Korhan Bey zaten amaç birinci sıradaki sayfa ismini almak.
 
Kapalı dosyadaki sayfa isimlerini değiştirip dener misiniz?
 
Haklısınız.
Aşağıdaki şekilde deneyin.
Kod: 
DefObj C, E-F, R
Sub Emre()
On Local Error Resume Next
Range("A2:J65536").ClearContents
Set Rky = CreateObject("adodb.connection")
Set fso = CreateObject("scripting.filesystemobject")
Set cat = CreateObject("adox.catalog")
For Each evn In fso.getfolder(ThisWorkbook.Path).Files
If Not evn.Name Like "*" & ThisWorkbook.Name Then
Rky.Open "Provider=Microsoft.ace.oledb.12.0;Data Source=" & _
evn & ";Extended Properties=""Excel 12.0;hdr=no"""

cat.activeconnection = Rky
For Each syf In cat.tables
    sayfaadi = Replace(syf.Name, "$", "")
Next

Set rs = Rky.Execute("Select * from [" & sayfaadi & "$A2:J2]")
Range("A65536").End(3)(2, 1).CopyFromRecordset rs
rs.Close: Rky.Close
End If
Next evn
Set rs = Nothing: Set Rky = Nothing: sorgu = ""
Set fso = Nothing: Set evn = Nothing
End Sub
 
Alternatif olarak dosyaları açıp verileri alan kodu deneyebilirsiniz. Verileri biçimleriyle aktardığı için tercih edebilirsiniz.

1.000 dosya üzerinde test yaptım.

ADO ile çözüm 47 Saniye sürdü.
Benim önerim 124 Saniye sürdü.

Kod: 
Sub Verileri_Aktar()
    Dim Zaman As Double, Yol As String
    Dim Dosya As String, S1 As Worksheet
    
    Application.ScreenUpdating = False
    Zaman = Timer
    
    Range("A2:J" & Rows.Count).ClearContents
    
    Yol = ThisWorkbook.Path & "\"
    Dosya = Dir(Yol & "*.xls*")
    
    While Dosya <> ""
        If Dosya <> ThisWorkbook.Name Then
            GetObject (Yol & Dosya)
            Set S1 = Workbooks(Dosya).Sheets(1)
            S1.Range("A2:J2").Copy Cells(Rows.Count, 1).End(3)(2, 1)
            Workbooks(Dosya).Close
        End If
        Dosya = Dir
    Wend
    
    Set S1 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşlem süresi ; " & Format(Timer - Zaman, "0.00000") & " Saniye"
End Sub
 
askm
askm' Alıntı:
Haklısınız.
Aşağıdaki şekilde deneyin.
Kod: 
DefObj C, E-F, R
Sub Emre()
On Local Error Resume Next
Range("A2:J65536").ClearContents
Set Rky = CreateObject("adodb.connection")
Set fso = CreateObject("scripting.filesystemobject")
Set cat = CreateObject("adox.catalog")
For Each evn In fso.getfolder(ThisWorkbook.Path).Files
If Not evn.Name Like "*" & ThisWorkbook.Name Then
Rky.Open "Provider=Microsoft.ace.oledb.12.0;Data Source=" & _
evn & ";Extended Properties=""Excel 12.0;hdr=no"""

cat.activeconnection = Rky
For Each syf In cat.tables
    sayfaadi = Replace(syf.Name, "$", "")
Next

Set rs = Rky.Execute("Select * from [" & sayfaadi & "$A2:J2]")
Range("A65536").End(3)(2, 1).CopyFromRecordset rs
rs.Close: Rky.Close
End If
Next evn
Set rs = Nothing: Set Rky = Nothing: sorgu = ""
Set fso = Nothing: Set evn = Nothing
End Sub
Genişletmek için tıkla ...

askm hocam kapalı dosyada birden fazla sayfa var, ben sayfa2 deki a2:j2 satırını almak istiyorum, koddda bunu belirtece yer bulamadım.
 
Korhan Ayhan' Alıntı:
Alternatif olarak dosyaları açıp verileri alan kodu deneyebilirsiniz. Verileri biçimleriyle aktardığı için tercih edebilirsiniz.

1.000 dosya üzerinde test yaptım.

ADO ile çözüm 47 Saniye sürdü.
Benim önerim 124 Saniye sürdü.

Kod: 
Sub Verileri_Aktar()
    Dim Zaman As Double, Yol As String
    Dim Dosya As String, S1 As Worksheet
   
    Application.ScreenUpdating = False
    Zaman = Timer
   
    Range("A2:J" & Rows.Count).ClearContents
   
    Yol = ThisWorkbook.Path & "\"
    Dosya = Dir(Yol & "*.xls*")
   
    While Dosya <> ""
        If Dosya <> ThisWorkbook.Name Then
            GetObject (Yol & Dosya)
            Set S1 = Workbooks(Dosya).Sheets(1)
            S1.Range("A2:J2").Copy Cells(Rows.Count, 1).End(3)(2, 1)
            Workbooks(Dosya).Close
        End If
        Dosya = Dir
    Wend
   
    Set S1 = Nothing
   
    Application.ScreenUpdating = True
   
    MsgBox "İşlem süresi ; " & Format(Timer - Zaman, "0.00000") & " Saniye"
End Sub
Genişletmek için tıkla ...

Korhan Hocam ilginize teşekkürler. Yazmız olduğunuz kod dediğiniz gibi veri biçimleri ile kopyalıyor, açık dosyamı biraz bozdu açıkçası.
Kapalı dosyalarda birden fazla sayfa var, ben sadece safya2 (isimleri diğişik olabiliyor) a2:j2 satırını açık olan dosyaya alt alta kopyalamak istiyorum.
 
Kod: 
DefObj C, E-F, R
Sub Emre()
On Local Error Resume Next
Range("A2:J65536").ClearContents
Set Rky = CreateObject("adodb.connection")
Set fso = CreateObject("scripting.filesystemobject")
Set cat = CreateObject("adox.catalog")
For Each evn In fso.getfolder(ThisWorkbook.Path).Files
If Not evn.Name Like "*" & ThisWorkbook.Name Then
Rky.Open "Provider=Microsoft.ace.oledb.12.0;Data Source=" & _
evn & ";Extended Properties=""Excel 12.0;hdr=no"""

cat.activeconnection = Rky
For Each syf In cat.tables
    a = a + 1
    sayfaadi = Replace(syf.Name, "$", "")
    If a = 2 Then Exit For
Next

Set rs = Rky.Execute("Select * from [" & sayfaadi & "$A2:J2]")
Range("A65536").End(3)(2, 1).CopyFromRecordset rs
rs.Close: Rky.Close
End If
Next evn
Set rs = Nothing: Set Rky = Nothing: sorgu = ""
Set fso = Nothing: Set evn = Nothing
End Sub
Korhan Beyin kodları;
Kod: 
Sub Verileri_Aktar()
    Dim Zaman As Double, Yol As String
    Dim Dosya As String, S1 As Worksheet
    
    Application.ScreenUpdating = False
    Zaman = Timer
    On error resume next
    Range("A2:J" & Rows.Count).ClearContents
    
    Yol = ThisWorkbook.Path & "\"
    Dosya = Dir(Yol & "*.xls*")
    
    While Dosya <> ""
        If Dosya <> ThisWorkbook.Name Then
            GetObject (Yol & Dosya)
            Set S1 = Workbooks(Dosya).Sheets(2)
            S1.Range("A2:J2").Copy Cells(Rows.Count, 1).End(3)(2, 1)
            Workbooks(Dosya).Close
        End If
        Dosya = Dir
    Wend
    
    Set S1 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşlem süresi ; " & Format(Timer - Zaman, "0.00000") & " Saniye"
End Sub
 
Eğer sayfa isimleri bütün dosyalarda aynıysa, aşağıdaki kod biraz daha hızlıdır.

Benim bilgisayarda 1000 adet dosyadan veriler yaklaşık 3 ~ 4 saniyede alınıyor.

Kapalı dosyaların bulunduğu yer; C:\TestFolder\KapaliDosyalar olmalı, kodların yazılacağı dosya ise başka herhangi bir yerde olabilir.


Kod: 
Sub GetData()
    'Haluk - 27/10/2018
    Dim Time1 As Date, Time2 As Date
    Dim timeElapsed As String, myFile As String
    Dim mySheet As String
    Dim FSO As Object, SourceFolder As Object
    Dim NoA As Long
   
    Time1 = Now
    Range("A2:J" & Rows.Count) = Empty
    mySheet = "Sayfa1"
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder("C:\TestFolder\KapaliDosyalar")
   
    For Each FileItem In SourceFolder.Files
        NoA = Cells(65536, 1).End(xlUp).Row + 1
       
        myFile = FileItem.Path
       
        FileExt = FSO.GetExtensionName(myFile)
       
        If FileExt = "xls" Or FileExt = "xlsx" Then
            myStr = "='" & SourceFolder & Application.PathSeparator
            myStr = myStr & "[" & FileItem.Name & "]" & mySheet & "'"
            Range("A" & NoA & ":J" & NoA).FormulaArray = myStr & "!A2:J2"
            Range("A" & NoA & ":J" & NoA) = Range("A" & NoA & ":J" & NoA).Value2
        End If
    Next
    Time2 = Now
    timeElapsed = Format(Time2 - Time1, "hh:mm:ss,ms")
    MsgBox "İşlem süresi: " & timeElapsed
    Range("A1").Select
End Sub

.
 
Son düzenleme:
Haluk' Alıntı:
Eğer sayfa isimleri bütün dosyalarda aynıysa, aşağıdaki kod biraz daha hızlıdır.

Benim bilgisayarda 1000 adet dosyadan veriler yaklaşık 3 ~ 4 saniyede alınıyor.

Kapalı dosyaların bulunduğu yer; C:\TestFolder\KapaliDosyalar olmalı, kodların yazılacağı dosya ise başka herhangi bir yerde olabilir.


Kod: 
Sub GetData()
    'Haluk - 27/10/2018
    Dim Time1 As Date, Time2 As Date
    Dim timeElapsed As String, myFile As String
    Dim mySheet As String
    Dim FSO As Object, SourceFolder As Object
    Dim NoA As Long
  
    Time1 = Now
    Range("A2:J" & Rows.Count) = Empty
    mySheet = "Sayfa1"
  
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder("C:\TestFolder\KapaliDosyalar")
  
    For Each FileItem In SourceFolder.Files
        NoA = Cells(65536, 1).End(xlUp).Row + 1
      
        myFile = FileItem.Path
      
        FileExt = FSO.GetExtensionName(myFile)
      
        If FileExt = "xls" Or FileExt = "xlsx" Then
            myStr = "='" & SourceFolder & Application.PathSeparator
            myStr = myStr & "[" & FileItem.Name & "]" & mySheet & "'"
            Range("A" & NoA & ":J" & NoA).FormulaArray = myStr & "!A2:J2"
            Range("A" & NoA & ":J" & NoA) = Range("A" & NoA & ":J" & NoA).Value2
        End If
    Next
    Time2 = Now
    timeElapsed = Format(Time2 - Time1, "hh:mm:ss,ms")
    MsgBox "İşlem süresi: " & timeElapsed
    Range("A1").Select
End Sub

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

Haluk Bey teşekkürler. Sayfa isimleri sabit değil. Gayet güzel çalışıyor. Daha sonra kullanmak üzere arşivime ekledim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst