Excel sayfalarını ayrı kitaplar halinde kayıt etme

cimbom05 · 23 Şubat 2009

İyi günler,
Çalıştığımız excel dosyaları bir klasör içerisinde bulunmaktadır. Her bir excel dosyası farklı isimlerdedir ve içerisinde de farklı isimlerde sheetler mevcuttur. Yapmak istediğim şey her sayfayı ayrı bir kitap olarak benim tanımlayacağım bir klasöre atması ve adını "dosya adı_sheet adı.xls" olarak kayıt etmesi. Örneğin rapor.xls içerisinde 01.01.2009 ve 01.02.2009 isimli sheetler mevcut ise bu sheetleri c:\belgelerim klasörü içerisine
"rapor_01.01.2009.xls" ve
"rapor_01.02.2009.xls "
dosyaları olarak kayıt etmesi.
Forumda sheet ismi ile kayıt örnekleri mevcut. Ancak dosya adı_sheet adı ile ilişkilendirilmiş bir çalışma bulamadığım için yeni konu açtım.
İlginize ve anlayışınıza teşekkür ederim.

bulentkars · 23 Şubat 2009

aşağıdaki makro işiniz çözecek
Sub Kitaplara_Ayir()

Set tumu = ActiveWorkbook
For i = 3 To Worksheets.Count
tumu.Sheets(i).copy
ActiveWorkbook.SaveAs "C:\BULENT" & tumu.Worksheets(i).Name
ActiveWorkbook.Close
Next i
End Sub

cimbom05 · 23 Şubat 2009

İyi akşamlar bulentkars
Bu kod ile dosyadaki son sayfaya ait kitap açarak C' ye kayıt ediyor. Sheet isminde uzantı olmadığı için uzantı koymuyor. Ayrıca dosya adı olarak BULENT ismini kullanıyor. İstediğim çalışmaya bir örnek ekliyorum

Korhan Ayhan · 23 Şubat 2009

Selamlar,

Aşağıdaki kodu denermisiniz.

Kod:

Option Explicit
 
Sub SAYFALARI_KAYDET()
    Dim Sayfa As Worksheet, Dosya_Adı As String, Dosya_Yolu As Object, Onay
    Application.ScreenUpdating = False
    Set Dosya_Yolu = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", 1)
    If Not Dosya_Yolu Is Nothing Then
    Onay = MsgBox(ThisWorkbook.Name & " isimli dosyanızdaki sayfalar " & vbCrLf & Dosya_Yolu.Self.Path & vbCrLf & "adresine kayıt edilecektir. Onaylıyor musunuz ?", vbYesNo + vbExclamation, "Dikkat !")
    If Onay = vbYes Then
    For Each Sayfa In Worksheets
    Dosya_Adı = Replace(ThisWorkbook.Name, ".xls", "")
    Sayfa.Copy
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=Dosya_Yolu.Self.Path & "\" & Dosya_Adı & " - " & ActiveSheet.Name & ".xls", FileFormat:=xlNormal, _
    Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWindow.Close
    Application.DisplayAlerts = True
    Next
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Else
    Application.ScreenUpdating = True
    MsgBox "İşleminiz iptal edilmiştir.", vbExclamation, "Dikkat !"
    End If
    Else
    Application.ScreenUpdating = True
    MsgBox "İşleminiz iptal edilmiştir.", vbExclamation, "Dikkat !"
    End If
End Sub

dEdE · 24 Şubat 2009

Merhaba,
Dosyanız ilişiktedir.

cimbom05 · 24 Şubat 2009

İyi akşamlar
Sayın Korhan Ayhan, bu işlemi yaptırırken işlem yapmak istediğimiz dosyaların bulunduğu klasörü seçmemiz mümkün olabilir mi?
Sayın dEdE eklemiş olduğunuz dosya istendiği şekilde çalışıyor. Ancak anladığım kadarı ile eklemiş olduğunuz modülü işlem yapmak istediğimiz her dosyaya eklememiz gerekiyor. Bu çok olası değil. Çünkü bu dosyaların sayısı azımsanmayacak kadar çok.
Ayrıca modülün içerisinde gördüğüm dosya adı "Rapor" olarak tanımlanmış (örnek dosya da o şekilde olduğu için sanırım) Ancak dosya isimleri sabit değildir. Bu nedenle her dosya için ismi dosya isminden alması gereketiğini düşünmüyorum. Zaman ayırdığınız için teşekkür ediyorum.

Korhan Ayhan · 24 Şubat 2009

Selamlar,

Üstteki mesajımdaki kodu güncelledim. İncelermisiniz.

cimbom05 · 24 Şubat 2009

İyi günler Sayın Korhan Ayhan
Malesef bu kod ile dosyaları kaydedeceğimiz klasörü seçebiliyoruz. Ancak sayfalarını ayırmak istediğimiz dosyaların bulunduğu klasörü seçemiyoruz. Ayrıca bu kodu sayfalarını ayırmak istediğimiz dosyaya yazmamız gerekiyor. Tanımlamamda hata var sanırım. Bu nedenle tekrar ifade edeyim. Yapmak istediğim şey,
Bir klasörün içinde yaklaşık 100 excel dosyası var. Bu dosyaların içerisinde değişen sayıda ve değişen isimlerde sayfalar var.
İstediğimiz şey, her bir sayfayı Excel dosyası olarak kaydetmek ve bu kayıtı yaparken dosya ismini sayfanın alındığı "dosya ismi_sayfa ismi.xls" olarak bizim belirleyeceğimiz bir klasöre kaydetmek. Anlayışınız ve yardımlarınız için teşekkür ederim.

Korhan Ayhan · 24 Şubat 2009

Selamlar,

Ben sorunuzu o an açık olan dosyanızdaki sayfaları ayrı excel dosyaları olarak kaydetmek istiyorsunuz şeklinde yorumlamıştım. En son mesajınızı okuyunca farklı bir isteğiniz olduğunu anladım. Sanırım aşağıdaki kod işinizi görecektir. İncelermisiniz.

Kod:

Option Explicit
 
Sub SAYFALARI_KAYDET()
    Dim Dosya_Adı As String, Kaynak_Dosya_Yolu As Object, Hedef_Dosya_Yolu As Object, Onay As Byte
    Dim Dosya As Object, Kaynak_Dosya As Workbook, Sayfa As Worksheet
 
    Set Kaynak_Dosya_Yolu = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen KAYNAK klasörü seçin !", 1)
    If Kaynak_Dosya_Yolu Is Nothing Then
    Application.ScreenUpdating = True
    MsgBox "İşleminiz iptal edilmiştir.", vbExclamation, "Dikkat !"
    Exit Sub: End If
 
    Set Hedef_Dosya_Yolu = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen HEDEF klasörü seçin !", 1)
    If Hedef_Dosya_Yolu Is Nothing Then
    Application.ScreenUpdating = True
    MsgBox "İşleminiz iptal edilmiştir.", vbExclamation, "Dikkat !"
    Exit Sub: End If
 
    Onay = MsgBox(Kaynak_Dosya_Yolu.Self.Path & "   isimli klasördeki excel dosyalarınızdaki sayfalar " & vbCrLf & Hedef_Dosya_Yolu.Self.Path & "   klasörüne kayıt edilecektir." & vbCrLf & "Onaylıyor musunuz ?", vbYesNo + vbExclamation, "Dikkat !")
    If Onay = vbYes Then
 
    If CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak_Dosya_Yolu.Self.Path).Files.Count = 0 Then GoTo Son
 
    Application.ScreenUpdating = False
 
    For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak_Dosya_Yolu.Self.Path).Files
 
    Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
 
        For Each Sayfa In Kaynak_Dosya.Worksheets
            Dosya_Adı = Replace(Kaynak_Dosya.Name, ".xls", "")
            Sayfa.Copy
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs Filename:=Hedef_Dosya_Yolu.Self.Path & "\" & Dosya_Adı & " - " & ActiveSheet.Name & ".xls", FileFormat:=xlNormal, _
            Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
            ActiveWindow.Close True
            Application.DisplayAlerts = True
        Next
 
    Kaynak_Dosya.Close False
 
    Next
 
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Else
    Application.ScreenUpdating = True
    MsgBox "İşleminiz iptal edilmiştir.", vbExclamation, "Dikkat !"
    End If
    Exit Sub
Son:
    Application.ScreenUpdating = True
    MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub

cimbom05 · 24 Şubat 2009

Sayın Korhan Ayhan,
Yardımlarınız için teşekkür ederim. Ayrıca isteğimi net ifade edemeyerek sizin zamanınızı aldığım için özür dilerim. Yaptığınız çalışma ile istenilen sonuç gerçekleşmiştir.

denniz · 27 Şubat 2009

Sayın Korhan Ayhan ;

diğer sayfalardaki verilere bağlantı içeren durumlarda fomuller bozularak geliyor . Bu formullerin çalışması bozulmadan bağlantılar aynı kalacak şekilde nasıl sayfalar halinde kayıt yapılabilir .

Korhan Ayhan · 27 Şubat 2009

Selamlar,

Sn. denniz,

Aysonlarında hazırlamış olduğum yaklaşık 50 sayfalık maliyet raporumda denedim. Raporumda kendi içinde sayfalarda bağlantılı formüller olduğu gibi başka dosyalarlada bağlantısı olan sayfalar bulunmaktadır. Denememde hiçbir sıkıntı yaşamadım.

denniz · 27 Şubat 2009

Sn Korhan bey ;
üzerinde denediğim dosyam benimde bir hayli kabarık . Ancak etopla fonksiyonu ile oluşan formüller kullanmaktayım . Bunların hepside #DEĞER! şeklinde görünüyor . örnek olması amacı ile kullandığım kodu veriyorum . =ETOPLA('C:\Documents and Settings\windows1\Desktop\Yeni Klasör\[üretimtakipprogramıV1.2.xls]Ara Stok 17'!A$4:A$2000;A6;'C:\Documents and Settings\windows1\Desktop\Yeni Klasör\[üretimtakipprogramıV1.2.xls]Ara Stok 17'!E$4:E$2000)
yardımcı olabilirseniz herkese faydalı olacağını umuyorum .

Korhan Ayhan · 27 Şubat 2009

Selamlar,

Üstteki mesajımdaki kodu ve dosyayı yeniledim. Denermisiniz.

denniz · 27 Şubat 2009

Selamlar ;
Örnek.xls dosyanız ile denemdim ancak gene olmuyor . Makrolar konusunda oldukça bilgisizim . Sorunun nereden kaynaklandığını anlayamadım .Örnek olması açısından sayfanın bir tanesini ve yazılan bir satır formülü gönderiyorum . Yardımlarınız için şimdiden teşekkür ederim .

denniz · 28 Şubat 2009

Tekrar Merhaba ;
TOPLA.ÇARPIM 'lı formüllerin kullanıldığı sayfalarda bir sorun olmuyor . Ancak ETOPLA ile yazılmış fomuller çalışmıyor . Bu sorun giderilemez mi ?

Korhan Ayhan · 28 Şubat 2009

Selamlar,

Bildiğim kadarıyla ETOPLA formülü kullanılan ve bağlantı kurulan iki dosyanında açık olması gerekiyor. Bu şekilde denerseniz sanırım sorunu çözebilirsiniz.

denniz · 28 Şubat 2009

Küçük hatırlatmanız için teşekkür ederim . Oldukça işime yarayacak bir makro idi bu . bir an için ETOPLA nın özelliğini unutmuşum . Teşekkürler . İyi çalışmalar dilerim .

muratgunay48 · 24 Kasım 2023

dEdE' Alıntı:
Merhaba,
Dosyanız ilişiktedir.

Hocam öncelikle emeğinize sağlık. Çok güzel bir çalışma.
Hocam peki aynı şekilde sayfaları PDF formatında yedeklemek istesek, nasıl yapabiliriz.
Teşekkür ederim.

breko52 · 28 Aralık 2023

Korhan Ayhan' Alıntı:

Selamlar,

Ben sorunuzu o an açık olan dosyanızdaki sayfaları ayrı excel dosyaları olarak kaydetmek istiyorsunuz şeklinde yorumlamıştım. En son mesajınızı okuyunca farklı bir isteğiniz olduğunu anladım. Sanırım aşağıdaki kod işinizi görecektir. İncelermisiniz.

Kod:

Option Explicit

Sub SAYFALARI_KAYDET()
    Dim Dosya_Adı As String, Kaynak_Dosya_Yolu As Object, Hedef_Dosya_Yolu As Object, Onay As Byte
    Dim Dosya As Object, Kaynak_Dosya As Workbook, Sayfa As Worksheet

    Set Kaynak_Dosya_Yolu = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen KAYNAK klasörü seçin !", 1)
    If Kaynak_Dosya_Yolu Is Nothing Then
    Application.ScreenUpdating = True
    MsgBox "İşleminiz iptal edilmiştir.", vbExclamation, "Dikkat !"
    Exit Sub: End If

    Set Hedef_Dosya_Yolu = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen HEDEF klasörü seçin !", 1)
    If Hedef_Dosya_Yolu Is Nothing Then
    Application.ScreenUpdating = True
    MsgBox "İşleminiz iptal edilmiştir.", vbExclamation, "Dikkat !"
    Exit Sub: End If

    Onay = MsgBox(Kaynak_Dosya_Yolu.Self.Path & "   isimli klasördeki excel dosyalarınızdaki sayfalar " & vbCrLf & Hedef_Dosya_Yolu.Self.Path & "   klasörüne kayıt edilecektir." & vbCrLf & "Onaylıyor musunuz ?", vbYesNo + vbExclamation, "Dikkat !")
    If Onay = vbYes Then

    If CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak_Dosya_Yolu.Self.Path).Files.Count = 0 Then GoTo Son

    Application.ScreenUpdating = False

    For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak_Dosya_Yolu.Self.Path).Files

    Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)

        For Each Sayfa In Kaynak_Dosya.Worksheets
            Dosya_Adı = Replace(Kaynak_Dosya.Name, ".xls", "")
            Sayfa.Copy
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs Filename:=Hedef_Dosya_Yolu.Self.Path & "\" & Dosya_Adı & " - " & ActiveSheet.Name & ".xls", FileFormat:=xlNormal, _
            Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
            ActiveWindow.Close True
            Application.DisplayAlerts = True
        Next

    Kaynak_Dosya.Close False

    Next

    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Else
    Application.ScreenUpdating = True
    MsgBox "İşleminiz iptal edilmiştir.", vbExclamation, "Dikkat !"
    End If
    Exit Sub
Son:
    Application.ScreenUpdating = True
    MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub

Merhaba sayın hocam bu kodu çalıştırdığımda sadece son sayfaki veriyi ayrı sayfaya kaydediyor. Diğer sayfalar hiç olmuyor.
Bir yerde mi yanlışlık yapıyorum acaba?
Teşekkürler şimdiden.

Excel sayfalarını ayrı kitaplar halinde kayıt etme

cimbom05

bulentkars

cimbom05

Ekli dosyalar

Korhan Ayhan

Administrator

dEdE

Destek Ekibi

Ekli dosyalar

cimbom05

Korhan Ayhan

Administrator

cimbom05

Korhan Ayhan

Administrator

Ekli dosyalar

cimbom05

denniz

Korhan Ayhan

Administrator

denniz

Korhan Ayhan

Administrator

denniz

Ekli dosyalar

denniz

Korhan Ayhan

Administrator

denniz

muratgunay48

breko52