Exceldeki sayfaları farklı kaydetme

[msalvarli]

Herkese selam,

Benim söyle bir sorum olacak. Mesela bir excel dosyam var. Bu dosyanın içinde sayfa1, sayfa2 ve sayfa3 diye çalışma sayfaları mevcut. Bir makro veya komutla bu çalışma sayfalarını farklı bir klasöre ayrı ayrı excel dosyası olacak şekilde kaydedebilirmiyim. Sayfa1 ayrı bir excel dosyası, sayfa2 ayrı, sayfa3 ayrı... 3 çalışma sayfası olan exceli save as ile 3 ayrı dosyaya ayırmak. Umarım anlatabilmişimdir. Forumlarda aradım ama bulamadım gerçi biraz acelem olduğu için acele ile baktım. umarım yardım edebilirsiniz. teşekkürler...

 

[Mahmut Bayram]

Sub sayfalari_ayir_kaydet()
    Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
    MyFilePath$ = ActiveWorkbook.Path & "\" & _
    Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
         On Error Resume Next
        MkDir MyFilePath
        For N = 1 To Sheets.Count
            Sheets(N).Activate
            SheetName = ActiveSheet.Name
            Cells.Copy
            Workbooks.Add (xlWBATWorksheet)
            With ActiveWorkbook
                With .ActiveSheet
                    .Paste
                    .Name = SheetName
                    [A1].Select
                End With
                  
                .SaveAs Filename:=MyFilePath _
                & "\" & SheetName & ".xls"
                .Close SaveChanges:=True
            End With
            .CutCopyMode = False
        Next
    End With
    Sayfa1.Activate
End Sub

 

[msalvarli]

Sub Macro1()
'
' Macro1 Macro
' Macro recorded 27/05/2008 by msalvarli'
' Keyboard Shortcut: Ctrl+y


On Error Resume Next
MkDir "C:\Documents and Settings\msalvarli\Desktop\Örnek\database_pages\"
Application.DisplayAlerts = False
For x = 1 To Sheets.Count
Sheets(x).Select 'Sayfayı sayar
ActiveSheet.Copy ' sayfanın yeni bir workbook''a kopyasını alır
ChDir "C:\Documents and Settings\msalvarli\Desktop\Örnek\database_pages\" 'klasorü hedef gösterir
ad = ActiveSheet.Name
ActiveWorkbook.SaveAs Filename:="C:\Documents and Settings\msalvarli\Desktop\Örnek\database_pages\" & ad, FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False



ActiveWorkbook.Save
ActiveWorkbook.Close

Next
End Sub


ile sorunumu çözdüm.... teşekkürler...

 

[msalvarli]

sayın mahmutt, ilginiz için teşekkürler...

 

[msalvarli]

sayın mahmutt, hazır sizi yakalamışken yukarıda yazdığım makronun 10dk da bir çalışmasını nasıl halledebilirim... nasıl bir kod yazmam gerekir...

 

[Mahmut Bayram]

Ayrı bir makro yazın ve aşağıdaki kodlardaki kalın puntolu yukarıdaki makro isimini değiştirin. veya ben yazıyım.

Sub auto_open()
Application.OnTime Now + TimeValue("00:10:00"), "[B]Macro1[/B]"
End Sub
 
Sub [B]Macro1[/B]()
'
' Macro1 Macro
' Macro recorded 27/05/2008 by msalvarli'
' Keyboard Shortcut: Ctrl+y


On Error Resume Next
MkDir "C:\Documents and Settings\msalvarli\Desktop\Örnek\database_pages\"
Application.DisplayAlerts = False
For x = 1 To Sheets.Count
Sheets(x).Select 'Sayfayı sayar
ActiveSheet.Copy ' sayfanın yeni bir workbook''a kopyasını alır
ChDir "C:\Documents and Settings\msalvarli\Desktop\Örnek\database_pages\" 'klasorü hedef gösterir
ad = ActiveSheet.Name
ActiveWorkbook.SaveAs Filename:="C:\Documents and Settings\msalvarli\Desktop\Örnek\database_pages\" & ad, FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False

ActiveWorkbook.Save
ActiveWorkbook.Close

Next
End Sub

 

[ckkaraca]

msalvarlının sorusuna benzer bir sorum olacak bu yüzden ayrı bir konu açmadan burda sorayım dedim.Userform ve buton atanmış bir dosyada farklı kaydet dediğimde sadece ilk sayfayı kaydedecek ve ilk sayfadaki(diğerlerini gizlemeden sadece ilk sayfadaki) butonları gizleyecek bir makro yada sorun başka bir şekilde çözmenin yolu var mı? Yardımlarınız için teşekkürler.

 

[Mahmut Bayram]

Buton derken sayfa1 de butonlar mı var.
Bir örnek dosya eklerseniz daha iyi anlaşılacağı kanaatindeyim.

 

[ckkaraca]

farklı kaydet

gönderdiğim ekte örmek mevcut.farklı kaydet dediğimde yada başka bir kısa yolla kaydedince sadece ön sayfanın kaydedilmesini ve butonların yer almasını istemiyorum ve tabi sadece ön sayfanın kaydedilmesini iistiyorum

 

[msalvarli]

sayın mahmutt, ilginiz ve yardımınız için teşekkürler...

yalnız bu yazdığınız excel'i açtıktan 10 dk sonra "Macro1" i çalıştırıyor.
Her 10dk da bir çalıştırmıyor. Yani sürekli 10 dakikada bir çalışmasını bekliyordum..

Sub auto_open()
Application.OnTime Now + TimeValue("00:10:00"), "Macro1"
End Sub

 

[Mahmut Bayram]

[LEFT]Sub auto_open()
Application.OnTime Now + TimeValue("00:10:00"), "[B]Macro1[/B]"
End Sub
 
Sub [B]Macro1[/B]()
'
' Macro1 Macro
' Macro recorded 27/05/2008 by msalvarli'
' Keyboard Shortcut: Ctrl+y


On Error Resume Next
MkDir "C:\Documents and Settings\msalvarli\Desktop\Örnek\database_pages\"
Application.DisplayAlerts = False
For x = 1 To Sheets.Count
Sheets(x).Select 'Sayfayı sayar
ActiveSheet.Copy ' sayfanın yeni bir workbook''a kopyasını alır
ChDir "C:\Documents and Settings\msalvarli\Desktop\Örnek\database_pages\" 'klasorü hedef gösterir
ad = ActiveSheet.Name
ActiveWorkbook.SaveAs Filename:="C:\Documents and Settings\msalvarli\Desktop\Örnek\database_pages\" & ad, FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False

ActiveWorkbook.Save
ActiveWorkbook.Close

Next

'buraya auto open i tekrar eklemelisiniz. Yani
[B][I]Call auto_open[/I][/B]
End Sub

[/LEFT]

 

[ckkaraca]

sayın mahmut ve msalvarlı yardım edebilir misiniz??

 

[Mahmut Bayram]

Şunu bir denemisiniz.

Sub Auto_Open()
Application.OnKey "{F12}", "kayit"
End Sub
 
Sub kayit()
Dim FileSave As String, Path As String
For Each buton In ActiveSheet.Shapes
   buton.Delete
Next
    With Sheets(1)
        .UsedRange.Copy
        .UsedRange.PasteSpecial xlValues
        .UsedRange.PasteSpecial xlFormats
        .Copy
    End With
    FileSave = Sheets(1).Name
    Path = Application.GetSaveAsFilename(FileSave, "Excel Workbooks (*.xls), *.xls")
End Sub