Çoklu Sayfa Kaydetme

[sekozzy]

Arkadaşlar, aşağıdaki makro kodu ile tek 1 sayfayı masaüstüne farklı kaydedebiliyorum. Bu kodu 2 veya daha fazla sayfayı tek dosyaya kaydetmem için nasıl düzenlemem gerekiyor? Bilgisi olan varsa yardımcı olabilir mi acaba?
NOT: Dosya Makra içerdiği için son olarak "Makro içermeyen çalışma kitabı olarak kaydetmeye devam etmek için Evet'e tıklayın." uyarısı alıyorum. Buna Evet deyip geçmem gerekiyor.

Sub Farkli_Kaydet()
    Sheets("Sayfa1").Copy
    ActiveWorkbook.SaveAs Environ("USERPROFILE") & "\Desktop\" & [A3] & " RAPOR" & ".xlsx"
    ActiveWindow.Close
End Sub

 

[Muzaffer Ali]

Aşağıdaki kodu kullanabilirsiniz.

Sub Farkli_Kaydet()
    Dim dsy As New Workbook
    Dim VbKod As Object
   
    ThisWorkbook.Sheets("Sayfa1").Copy
    Set dsy = ActiveWorkbook
   
    ThisWorkbook.Sheets("Sayfa2").Copy Before:=dsy.Sheets(1)
    ThisWorkbook.Sheets("Sayfa3").Copy Before:=dsy.Sheets(1)
    ThisWorkbook.Sheets("Sayfa4").Copy Before:=dsy.Sheets(1)
    'Bu şekilde devam edebilirsiniz.

    With dsy.VBProject
        For Each VbKod In .VBComponents
            Select Case VbKod.Type
            Case 1, 2, 3
                .VBComponents.Remove VbKod
            Case 100
                VbKod.CodeModule.DeleteLines 1, VbKod.CodeModule.CountOfLines
            End Select
        Next
    End With
    dsy.SaveAs Environ("USERPROFILE") & "\Desktop\" & [A3] & " RAPOR" & ".xlsx" ', FileFormat:=XlFileFormat.xlWorkbookNormal
    ActiveWindow.Close True
End Sub

 

[sekozzy]

Aşağıdaki kodu kullanabilirsiniz.

Sub Farkli_Kaydet()
    Dim dsy As New Workbook
    Dim VbKod As Object
  
    ThisWorkbook.Sheets("Sayfa1").Copy
    Set dsy = ActiveWorkbook
  
    ThisWorkbook.Sheets("Sayfa2").Copy Before:=dsy.Sheets(1)
    ThisWorkbook.Sheets("Sayfa3").Copy Before:=dsy.Sheets(1)
    ThisWorkbook.Sheets("Sayfa4").Copy Before:=dsy.Sheets(1)
    'Bu şekilde devam edebilirsiniz.

    With dsy.VBProject
        For Each VbKod In .VBComponents
            Select Case VbKod.Type
            Case 1, 2, 3
                .VBComponents.Remove VbKod
            Case 100
                VbKod.CodeModule.DeleteLines 1, VbKod.CodeModule.CountOfLines
            End Select
        Next
    End With
    dsy.SaveAs Environ("USERPROFILE") & "\Desktop\" & [A3] & " RAPOR" & ".xlsx" ', FileFormat:=XlFileFormat.xlWorkbookNormal
    ActiveWindow.Close True
End Sub

Sayın dalgalikur vermiş olduğunuz kod şifrelenmiş vba projelerinde şifre nedeniyle çalışmıyor. Şifreyi makro ile kaldırmamız mümkün mü?

 

[Muzaffer Ali]

Hayır, forum kuralları gereği şifre kaldırmak gibi işlemleri yapmıyoruz.

 

[sekozzy]

Hayır, forum kuralları gereği şifre kaldırmak gibi işlemleri yapmıyoruz.

Yanlış anlaşıldım sanırım. Şifre kırma değil, kendi koyduğum şifreyi kaldırmaktan bahsetmiştim.

 

[Korhan Ayhan]

Alternatif olarak deneyiniz.

Sub Farkli_Kaydet()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Sheets(Array("Sayfa1", "Sayfa2", "Sayfa3")).Copy
    ActiveWorkbook.SaveAs Filename:=Environ("UserProfile") & "\Desktop\" & Range("A3").Value & " RAPOR" & ".xlsx", _
    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close 1
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub