farklı excel dosyalarındaki sayfaları birleştirme

[HASANC]

benim bir klasörün içinde yaklaşık 10 adet excel dosyama var. ve bu dosyaların içlerinde farklı adetlerde sayfalar var. yani kimisinde 5 sayfa, kimisinde 1 sayfa ve sayfa isimleri;sayfa1,sayfa2 falan değil.hepsi değiştirilmiş, isimler farklı farklı, örneğin sayfanın birisinin ismi tofaş, diğerinin ismi ford vs. bu 10 adet excel dosyalarındaki sayfaları tek bir excel sayfasında alt alta toplaya bilirmiyim.

 

[Orion1]

benim bir klasörün içinde yaklaşık 10 adet excel dosyama var. ve bu dosyaların içlerinde farklı adetlerde sayfalar var. yani kimisinde 5 sayfa, kimisinde 1 sayfa ve sayfa isimleri;sayfa1,sayfa2 falan değil.hepsi değiştirilmiş, isimler farklı farklı, örneğin sayfanın birisinin ismi tofaş, diğerinin ismi ford vs. bu 10 adet excel dosyalarındaki sayfaları tek bir excel sayfasında alt alta toplaya bilirmiyim.

Toplayabilirisniz.
Ama diğer excel dosyalarındaki sayfaların satırlarının toplamı sizin sayfanızın satır sayısını geçmemeli.
2007 de sanırım yaklaşık 1 milyon satır var.

 

[HASANC]

geçmez. nasıl yapabilirm.

 

[Orion1]

geçmez. nasıl yapabilirm.

Örnek dosyalarınızı 2003 formatında yollarsanız ben kodu yazıp vereyim size
Eğer 2007 formatında istiyorsanzı başka bir arkadaştan yardım alın.Çünkü bende 2007 yok.

 

[HASANC]

klasörün içindeki dosyaları birleştirmek istiyorum.

 

[Orion1]

Dosyanız ektedir.

Sub dosyaları_birlestir_59()
Dim fso As Object, f As Object, dosya As String, fls As Object
Dim sonsat1 As Long, sonsat2 As Long, sh As Worksheet, liste()
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.getfolder(ThisWorkbook.Path & "\YENİ").Files
ThisWorkbook.Activate
ThisWorkbook.Sheets("Sayfa1").Select
Application.ScreenUpdating = False
Range("A:G").ClearContents
For Each fls In f
    If fso.GetExtensionName(fls) = "xls" Then
        If Workbooks.Open(fls).ReadOnly = True Then Workbooks(fls.Name).Close False
        For Each sh In Workbooks(fls.Name).Worksheets
            sonsat1 = sh.Cells(65536, "B").End(xlUp).Row
            If sonsat1 > 4 Then
                liste = sh.Range("A5:G" & sonsat1).Value
                sonsat2 = ThisWorkbook.Sheets("Sayfa1").Cells(65536, "B").End(xlUp).Row + 2
                ThisWorkbook.Sheets("Sayfa1").Range("A" & sonsat2).Resize(UBound(liste), 7) = liste
                Erase liste
            End If
        Next sh
        Workbooks(fls.Name).Close False
    End If
Next fls
ThisWorkbook.Activate
ThisWorkbook.Sheets("Sayfa1").Select
Application.ScreenUpdating = True
MsgBox "Diğer dosyalardan veriler aktarıldı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[HASANC]

tşk.mükkemmel çalışıyor. emeğe saygı.

 

[Orion1]

tşk.mükkemmel çalışıyor. emeğe saygı.

Rica ederim.
İyi çalışmalar.

 

[assenucler]

Emek ve katkınız için teşekkür sayın Evren Gizlen... Bizlerin her zaman ışığımız oluyorsunuz.

Her şey gönlünüzün güzelliği gibi olsun..

Sevgi ve saygılar..

 

[Orion1]

Emek ve katkınız için teşekkür sayın Evren Gizlen... Bizlerin her zaman ışığımız oluyorsunuz.

Her şey gönlünüzün güzelliği gibi olsun..

Sevgi ve saygılar..

Rica ederim.
Saygılar benden.