Kopyalama kodu yardım ve tarihsel sıralama

[Serdarrk]

Merhaba arkadaşlar,
Aşağıdaki kod ile klasördeki tüm excel dosyaları tek bir excel dosyasında toplanabilmekte ancak Sheets(1).Range("a1:l15000").Copy satırı nedeniyle diğer dosyalardaki sadece ilk sheet kopyalanmakta. Bunu klasördeki diğer dosyadaki bütün sheetleri kopyalacak şekilde nasıl değiştirebilirim?

İkinci bir sorumda excel çalışma dosyası içindeki sheetleri isimlerindeki tarihe göre sıralamak mümkün müdür?
Bir dosyada 12 ayın bazı günlerinin adını taşıyan sayfalar bulunmakta ve bunları örneğin; 01.01.2000, 01.02.2000,01.03.2000 şeklinde sıralanmakta ancak benim amacım takvimsel sıralama ile 01.01.2000, 02.01.2000...... 31.01.2000 devamında 01.02.2000, 02.02.2000....28.02.2000 şeklinde yapmak. Ayrıca bu isimler 01.01.2000 olduğu gibi 01-Oca-2000 şeklinde de varlar.Bu konuda yardımcı olabilir misiniz?

Private Sub CommandButton1_Click()
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set bukitap = ThisWorkbook
Set fso = CreateObject("scripting.filesystemobject")
For Each dosya In fso.getfolder(ThisWorkbook.Path).Files
   isim = Split(dosya.Name, ".")(0)
   If dosya.Name <> ThisWorkbook.Name And Mid(dosya.Name, 2, 1) <> "$" Then
     Set ac = Workbooks.Open(dosya)
     Sheets(1).Range("a1:l15000").Copy
     bukitap.Sheets.Add After:=Sheets(Sheets.Count)
     bukitap.ActiveSheet.Range("a65536").End(3)(2, 1).PasteSpecial xlPasteValues
     bukitap.ActiveSheet.Name = isim
     ac.Close False
   End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set ac = Nothing: Set dosya = Nothing: Set fso = Nothing
End Sub

 

[Muzaffer Ali]

1. Soru
Kodlarınızı aşağıdaki kodlarla değiştirin.

Private Sub CommandButton1_Click()
On Error Resume Next
Dim SayfaSayisi As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set bukitap = ThisWorkbook
Set fso = CreateObject("scripting.filesystemobject")
For Each dosya In fso.getfolder(ThisWorkbook.Path).Files
   isim = Split(dosya.Name, ".")(0)
   If dosya.Name <> ThisWorkbook.Name And Mid(dosya.Name, 2, 1) <> "$" Then
     Set ac = Workbooks.Open(dosya)
     For SayfaSayisi = 1 To ac.Sheets.Count
        ac.Sheets(1).Range("a1:l15000").Copy
        bukitap.Sheets.Add after:=Sheets(Sheets.Count)
        bukitap.ActiveSheet.Range("a65536").End(3)(2, 1).PasteSpecial xlPasteValues
        bukitap.ActiveSheet.Name = isim
     Next
     ac.Close False
   End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set ac = Nothing: Set dosya = Nothing: Set fso = Nothing
End Sub

2.Soru
Eğer sayfa isimlerindeki tarih formatları aynı olsaydı sıralama yapabilirdim fakat bu hali ile yapamadım.

 

[Serdarrk]

Kusura bakmayın mesajınızı yeni gördüm. Dosyaların bazılarında tarihler aynı formatta, bir örneği de ekte. Bu şekilde yardımcı olabilirseniz çok sevinirim, geriye kalan dosyalardaki tarihleri de aynı formatta düzeltmeye çalışırım. Aşağıdaki dosyada tarihler tamamen; 01.02.2007,02.02.2007 şeklinde, bazı dosyalar bu şekilde bazıları da 01-Şub-2005,02-Şub-2005 şeklinde. Eğer yardımcı olabilirseniz, iki formatında karışık olduğu dosyaları düzeltip öyle kodunuzu kullanabilirim.

http://s7.dosya.tc/server3/eldolb/01.02.2007-1.xls.html

 

[Serdarrk]

1. Soru
Kodlarınızı aşağıdaki kodlarla değiştirin.

Private Sub CommandButton1_Click()
On Error Resume Next
Dim SayfaSayisi As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set bukitap = ThisWorkbook
Set fso = CreateObject("scripting.filesystemobject")
For Each dosya In fso.getfolder(ThisWorkbook.Path).Files
   isim = Split(dosya.Name, ".")(0)
   If dosya.Name <> ThisWorkbook.Name And Mid(dosya.Name, 2, 1) <> "$" Then
     Set ac = Workbooks.Open(dosya)
     For SayfaSayisi = 1 To ac.Sheets.Count
        ac.Sheets(1).Range("a1:l15000").Copy
        bukitap.Sheets.Add after:=Sheets(Sheets.Count)
        bukitap.ActiveSheet.Range("a65536").End(3)(2, 1).PasteSpecial xlPasteValues
        bukitap.ActiveSheet.Name = isim
     Next
     ac.Close False
   End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set ac = Nothing: Set dosya = Nothing: Set fso = Nothing
End Sub

2.Soru
Eğer sayfa isimlerindeki tarih formatları aynı olsaydı sıralama yapabilirdim fakat bu hali ile yapamadım.

Kusura bakmayın mesajınızı yeni gördüm. Dosyaların bazılarında tarihler aynı formatta, bir örneği de ekte. Bu şekilde yardımcı olabilirseniz çok sevinirim, geriye kalan dosyalardaki tarihleri de aynı formatta düzeltmeye çalışırım. Aşağıdaki dosyada tarihler tamamen; 01.02.2007,02.02.2007 şeklinde, bazı dosyalar bu şekilde bazıları da 01-Şub-2005,02-Şub-2005 şeklinde. Eğer yardımcı olabilirseniz, iki formatında karışık olduğu dosyaları düzeltip öyle kodunuzu kullanabilirim.

http://s7.dosya.tc/server3/eldolb/01.02.2007-1.xls.html