Formül ve Makro İçeren Çalışma Kitabını Değer Olarak Aynı Dosya İsmi ile Farklı Kaydetmek

[ekpe_babam]

Merhaba, öncelikle herkese iyi forumlar dilerim.

Elimde birden fazla sayfası olan ve hepsinde farklı formüller, makrolar olan bir çalışma kitabı var ve bu çalışma kitabında ayrıca bir de "çalışma kitabı koruması" bulunuyor. İstediğim şey çalışma kitabında "görünür durumda olan" tüm sayfaların formülsüz ve makrosuz olarak aynı isimle sadece uzantısı ".xlsx" ve mümkünse çalışma kitabı parolasının da iptal olacak şekilde ilk dosyanın bulunduğu konuma kaydedilmesidir.

Yine bu forumda eskiden açılmış bir konudan edindiğim bir makro var, bu makro sadece aktif sayfayı değer olarak yapıştırıyor, diğer sayfalardaki formül ve makroları kaldırmıyor aynı şekilde çalışma kitabı da korumalı olarak görünüyor. eski konunun linkini ve o sayfada kullandığım kodu aşağıda paylaşıyorum;

https://www.excel.web.tr/threads/formuel-ve-makro-iceren-calisma-kitabini-deger-olarak-farkli-kaydetmek.127896/

Sub farklı()
Dim YL As String, ÇLŞ As Variant, KÇLŞ As Variant
YL = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
KÇLŞ = ActiveWorkbook.Name
ÇLŞ = ActiveCell.Address
ActiveWorkbook.SaveAs YL & Replace(KÇLŞ, ".xlsm", ".xlsx"), xlOpenXMLWorkbook
Cells.Select: Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range(ÇLŞ).Select
ActiveWorkbook.Save
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Workbooks.Open (YL & KÇLŞ)
Workbooks(Replace(KÇLŞ, ".xlsm", ".xlsx")).Close
End Sub

Desteğiniz için şimdiden teşekkür ederim.

 

[Muzaffer Ali]

Merhaba.
Aşağıdaki kodlar ile yapabilirsiniz.

Sub Test()
    Dim Bak As Integer
    Dim Gizli As Boolean
    With ThisWorkbook
        For Bak = 1 To .Worksheets.Count
            If .Worksheets(Bak).Visible = False Then
                .Worksheets(Bak).Visible = True
                Gizli = True
            End If
            .Worksheets(Bak).Copy
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "/" & .Worksheets(Bak).Name
            ActiveWorkbook.Close
            If Gizli = True Then
                .Worksheets(Bak).Visible = False
                Gizli = False
            End If
        Next
    End With
End Sub

Eğer gizli olan sayfaları kaydetmek istemiyorsanız, aşağıdaki kodları kullanın.

Sub Test()
    Dim Bak As Integer
    With ThisWorkbook
        For Bak = 1 To .Worksheets.Count
            If .Worksheets(Bak).Visible = True Then
                .Worksheets(Bak).Copy
                ActiveWorkbook.SaveAs ThisWorkbook.Path & "/" & .Worksheets(Bak).Name
                ActiveWorkbook.Close
            End If
        Next
    End With
End Sub

 

[ekpe_babam]

Yardımınız için teşekkür ederim @dalgalikur hocam, ilettiğiniz iki kodu da denedim ( aslında amacım gizli sayfaları almamak) ancak ilettiğiniz kodlar her sayfayı ayrı ayarı çalışma kitabı olarak çıkarıyor ve makronun olduğu sayfaya gelince hata verip şu mesajı veriyor; "Worksheet sınıfının Visible özelliği kurulamıyor".

Benim istediğim ise sayfaları tek tek ayırması değilde ilk dosya gibi yine tek çalışma kitabı içinde "görünen tüm sayfaları" formülsüz (değer) ve makrosuz olarak ".xlsx" uzantılı şekilde ilk çalışma kitabının olduğu konuma kaydetmesidir.

Düzeltme: Kusura bakmayın @dalgalikur hocam, ikinci kodda tüm görünen sayfaları çıkarıyor sadece "xlsx" uzantılı kaydetmesinden dolayı hata değilde uyarı veriyor, makro içerebilmesi için kalsik verdiği uyarı vardır ya, bir de ayırlıan dosyaların hepsinde formüller kalıyor. Ama üstte de belirttiğim gibi istediğim tek tek sayfaları ayırması değilde ilk çalışma kitabı gibi toplu halde ismi aynı uzantısı "xlsx" olan tüm sayfaların formülsüz ve makrosuz olması.

Teşekkürler.

 

[Muzaffer Ali]

O zaman aşağıdaki kodları kullanın.

Sub Test()
    Dim Bak As Integer
    Dim WB As Workbook
    With ThisWorkbook
        For Bak = 1 To .Worksheets.Count
            If .Worksheets(Bak).Visible = True Then
                .Worksheets(Bak).Cells.Copy
                .Worksheets(Bak).Range("A1").PasteSpecial Paste:=xlPasteValues
        
                If WB Is Nothing Then
                    .Worksheets(Bak).Copy
                    Set WB = ActiveWorkbook
                Else
                    .Worksheets(Bak).Copy after:=WB.Worksheets(1)
                End If
            End If
        Next
        WB.SaveAs ThisWorkbook.Path & "/_Formülsüz", FileFormat:=xlOpenXMLWorkbook
        WB.Close
    End With
End Sub

 

[ekpe_babam]

O zaman aşağıdaki kodları kullanın.

Sub Test()
    Dim Bak As Integer
    Dim WB As Workbook
    With ThisWorkbook
        For Bak = 1 To .Worksheets.Count
            If .Worksheets(Bak).Visible = True Then
                .Worksheets(Bak).Cells.Copy
                .Worksheets(Bak).Range("A1").PasteSpecial Paste:=xlPasteValues
      
                If WB Is Nothing Then
                    .Worksheets(Bak).Copy
                    Set WB = ActiveWorkbook
                Else
                    .Worksheets(Bak).Copy after:=WB.Worksheets(1)
                End If
            End If
        Next
        WB.SaveAs ThisWorkbook.Path & "/_Formülsüz", FileFormat:=xlOpenXMLWorkbook
        WB.Close
    End With
End Sub

@dalgalikur hocam çok teşekkürler, bu şekilde sorunsuz bir şekilde çalıştı.

Ufak bir şey daha sorsam izninizle dosyayı "formülsüz" ismi ile değilde aynı isimle kaydetmesi için ne yapabilirim.

Bir de saçma gelebilir ama formüllü dosyadaki sayfa sıralarını tamamen değiştiriyor ve neye göre yapıyor bilmiyorum ama çok farklı sıraya göre diziyor, acaba bununda bozulmamasını sağlayabilir miyiz. Örneğin; sayfalar 1,2,3 gibi numaralar ile sıralıyken makro sonrası formülsüz dosyada 3,1,2 gibi sıralanıyor.

 

[Muzaffer Ali]

O zaman bu kodları kullanın.

Sub Test()
    Dim Bak As Integer
    Dim WB As Workbook
    With ThisWorkbook
        For Bak = 1 To .Worksheets.Count
            If .Worksheets(Bak).Visible = True Then
                .Worksheets(Bak).Cells.Copy
                .Worksheets(Bak).Range("A1").PasteSpecial Paste:=xlPasteValues
        
                If WB Is Nothing Then
                    .Worksheets(Bak).Copy
                    Set WB = ActiveWorkbook
                Else
                    .Worksheets(Bak).Copy after:=WB.Worksheets(WB.Worksheets.Count)
                End If
            End If
        Next
        WB.SaveAs Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 5), FileFormat:=xlOpenXMLWorkbook
        WB.Close
    End With
End Sub

 

[ekpe_babam]

@dalgalikur hocam çok çok teşekkür ederim şu an tam istediğim mantıkta çalışıyor eline sağlık.

son bir sorum olacak makroyu çalıştırdıktan sonra yeni dosya kaydediliyor buraya kadar her şey normal, işlem bittikten sonra makrolu dosyaya dönüyor buradan sonra dosyayı kapatırken değişiklikleri kaydet dersek asıl formüllü ve makrolu dosyayı da makrosuz ve formülsüz olarak kaydediyor, bu normal midir. Burada kullanıcıların genelde kaydet diyebileceğini düşünüyorum bunu da engellersek mükemmel olacak olmazsa da elinize sağlık sabahtan uğraştırdım sizi sağolun.

 

[Muzaffer Ali]

Kod aşağıda.

Sub Test()
    Dim Bak As Integer
    Dim WB As Workbook
    For Bak = 1 To ThisWorkbook.Worksheets.Count
        With ThisWorkbook.Worksheets(Bak)
            If .Visible = True Then
                If WB Is Nothing Then
                    .Copy
                    Set WB = ActiveWorkbook
                    WB.Worksheets(1).Cells.Copy
                    WB.Worksheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
                Else
                    .Copy after:=WB.Worksheets(WB.Worksheets.Count)
                    WB.Worksheets(WB.Worksheets.Count).Cells.Copy
                    WB.Worksheets(WB.Worksheets.Count).Range("A1").PasteSpecial Paste:=xlPasteValues
                End If
            End If
        End With
    Next
    WB.SaveAs Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 5), FileFormat:=xlOpenXMLWorkbook
    WB.Close
End Sub

 

[ekpe_babam]

@dalgalikur hocam emeğine, eline sağlık çok teşekkür ederim, hakkını helal et dosya sorunsuz şekilde çalışıyor. Kaydet denilse bile ana dosya formüllü ve makrolu devam ediyor.

 

[issever]

Kod aşağıda.

Sub Test()
    Dim Bak As Integer
    Dim WB As Workbook
    For Bak = 1 To ThisWorkbook.Worksheets.Count
        With ThisWorkbook.Worksheets(Bak)
            If .Visible = True Then
                If WB Is Nothing Then
                    .Copy
                    Set WB = ActiveWorkbook
                    WB.Worksheets(1).Cells.Copy
                    WB.Worksheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
                Else
                    .Copy after:=WB.Worksheets(WB.Worksheets.Count)
                    WB.Worksheets(WB.Worksheets.Count).Cells.Copy
                    WB.Worksheets(WB.Worksheets.Count).Range("A1").PasteSpecial Paste:=xlPasteValues
                End If
            End If
        End With
    Next
    WB.SaveAs Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 5), FileFormat:=xlOpenXMLWorkbook
    WB.Close
End Sub

Merhaba,

32 sekmeli "Makro İçerebilen Şablon" açtım, normal excel sayfası olarak kaydettim ve makroyu çalıştırdım. Şu hatayı verdi.

Debug satırı: WB.SaveAs Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 5), FileFormat:=xlOpenXMLWorkbook

Çözüm ne olabilir?

 

[efek_01]

banada bir yardım eli lazım galiba elimde hazırlamış olduğum bir vba makrolu dosyam var ve rapor alacağım sayfada bazı makrolu işlemlerim var buna göre makroları kaldırırsam sayfanın ismiyle dosyadan ayırıp ayrı bir şekilde masaüstüne alıyorum fakat makroları tekrar koyduğumda rapor sayfasına bu sefer sayfa vba olarak diye soruyor çalışan dosyayıda bozuyor bana makroları ile birlikte sayfanın ismi ile sayfayı excel dosyamdan ayırıp masa üstüne çıkarmam gerek banada sihirli bir el lazım sanırsam