Kapalı Dosyadan Açık Dosyaya Veri Alma

schlecht · 26 Ekim 2018

İ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.

schlecht · 26 Ekim 2018

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..

askm · 27 Ekim 2018

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

schlecht · 27 Ekim 2018

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?

askm · 27 Ekim 2018

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

schlecht · 27 Ekim 2018

Elinize sağlık, teşekkür ederim. Mükemmel çalışıyor.

Korhan Ayhan · 27 Ekim 2018

Merhaba,

Bence kodun hata vermesi gerekiyor...

Sebebi ise Sheets(1).Name ifadesi aktif dosyadaki sayfa adına bakar.

askm · 27 Ekim 2018

Korhan Bey zaten amaç birinci sıradaki sayfa ismini almak.

Korhan Ayhan · 27 Ekim 2018

Kapalı dosyadaki sayfa isimlerini değiştirip dener misiniz?

askm · 27 Ekim 2018

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

Korhan Ayhan · 27 Ekim 2018

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

schlecht · 27 Ekim 2018

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

askm hocam kapalı dosyada birden fazla sayfa var, ben sayfa2 deki a2:j2 satırını almak istiyorum, koddda bunu belirtece yer bulamadım.

schlecht · 27 Ekim 2018

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

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.

askm · 27 Ekim 2018

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

Haluk · 27 Ekim 2018

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

.

schlecht · 27 Ekim 2018

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

.

Haluk Bey teşekkürler. Sayfa isimleri sabit değil. Gayet güzel çalışıyor. Daha sonra kullanmak üzere arşivime ekledim.

Kapalı Dosyadan Açık Dosyaya Veri Alma

schlecht

Ekli dosyalar

schlecht

askm

Destek Ekibi

schlecht

askm

Destek Ekibi

schlecht

Korhan Ayhan

Administrator

askm

Destek Ekibi

Korhan Ayhan

Administrator

askm

Destek Ekibi

Korhan Ayhan

Administrator

schlecht

schlecht

askm

Destek Ekibi

Haluk

Özel Üye

schlecht