Farklı excel kitaplarındaki birinci sayfaları yeni bir excel kitabına toplamak

[uakturk]

Değerli Excel hocalarım,

Elimde kullandığım tek tek yapılmış excel kitapları var. Farklı farklı Excel kitaplarındaki birinci sayfaları yeni bir excel kitabında ve sayfalar halinde nasıl toplayabilirim.

Bu konu hakkında daha önce yaptığınız çalışmaları inceledim ama bu sorduğum konuyu başaramadım. "Çalışma kitaplarındaki sayfaları tek bir kitapta toplamak " (http://www.excel.web.tr/f50/aly-ma-kitaplaryndaki-sayfalary-tek-bir-kitapta-toplamak-t99316.html) başlığınızın altında Halit3 hocamın yazdığı kodları uyguladım fakat onun çalışma sonucu kitaplardaki tüm sayfaları almasıdır.Bu durum şu aşamada benim işime yaramamaktadır. Örnek olması açısından ekli dosyayıda koyuyorum.
Şimdiden ilgilenecek arkadaşlarıma çok teşekkür ediyorum.
Saygılarımla..

 

[dEdE]

Merhaba,
Ekli dosyayı inceler misiniz?

Sub VeriAl()
Application.ScreenUpdating = False
Dim ds, dc, f
    Set ds = CreateObject("Scripting.FileSystemObject")
    Set f = ds.GetFolder(ThisWorkbook.Path & "\")
   
    For Each Dosya In f.Files
        If Right(Dosya.Name, 4) = "xlsx" Then
            yol = ThisWorkbook.Path & "\"
            Workbooks.Open (yol & Dosya.Name)
            Workbooks(Dosya.Name).Sheets("Sayfa1").Copy After:=Workbooks("AnaDosya.xlsm").Sheets("Sayfa1")
            Sheets(ActiveSheet.Name).Name = Dosya.Name
            Workbooks(Dosya.Name).Close
        End If
Next
Application.ScreenUpdating = True
Sheets("Sayfa1").Select
MsgBox "İşlem Tamam...", vbInformation, "dEdE Başarılar Diler..."
End Sub

 

[uakturk]

Sayın dEdE hocam,
İlgin için çok teşekkür ederim. Gönderdiğin örnek dosya çok güzel olmuş, bu dosyayı kullanacağım klasörün içine kopyaladım. Excel dosyalarını uzantıları (.xls) olduğu için makroda bulunan .xlsx uzantılarını .xls olarak değiştirdim. Fakat dosyaları tek dosyaya çekemedim. Nerede hata yaptım acaba ? Saygılarımla,

 

[dEdE]

Merhaba,
Aşağıdaki satırda bulunan 4 rakamını 3 olarak değiştirdiniz mi?

If Right(Dosya.Name, 4) = "xlsx" Then

Yeni hali

If Right(Dosya.Name, [COLOR="Red"]3[/COLOR]) = "xls" Then

Bu satır dosya uzantısının kaç karakter olduğunu ve hangi karakterlerden oluştuğunu kontrol ediyor. Eski kod 4 karakterli ve xlsx. Yeni kod 3 karakterli ve xls.

 

[uakturk]

Sayın dEdE hocam,
İlginiz için tekrardan çok teşekkür ederim. Gönderdiğiniz örnek dosyada düzeltmeyi yaptım fakat ekteki hatayı verdi ve sadece ilk dosyanın ilk sayfasını alabildi.? Sizide çok yordum kusurama bakmayın lütfen,
Saygılarımla,

 

[dEdE]

Merhaba,
Hata veren satırdaki Anadosya uzantısını da .xls olarak değiştirmeniz gerekir.

İşin doğrusu ilk gönderdiğiniz dosyalar .xlsx uzantılı olduğü için ben de aynı formatta yanıtladım.
Eğer sorunu çözemezseniz, gerçek dosyanızı(veriler olmadan) gönderirseniz çözeriz. Ne de olsa meslektaş sayılırız.
Saygılar.

 

[uakturk]

Sayın dEdE Hocam,
Sağlık sektöründemisiniz?