Makro içeren bir excel sayfasını, makro içermeyen bir excel sayfası olarak dışarı aktrarmak

[Gold_Savt]

Makro içeren bir excel sayfam var. Bunu dışarı aktarırken yine makro içeren bir excel sayfası olarak aktarmak istemiyorum.
Aktardığım sayfada da makrolarım olduğundan dolayı makrosuz temiz bir çıktı istiyorum.
Benim kullandığım kodlar şu şekilde:

ActiveWorkbook.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & " " & DateTime.Minute(simdi) & " " & DateTime.Second(simdi) & "Çıktı", FileFormat:=xlOpenXMLWorkbookMacroEnabled

 

[halit3]

Sayfa için kod

Sub kayityap()

Klasor = CreateObject("wscript.Shell").SpecialFolders.Item("Desktop")
dosya_adi = "deneme15"

dosya = ThisWorkbook.FullName
uzanti = ".xlsx"
Sayfa_Adı = ActiveSheet.Name
ActiveSheet.Copy


For Each ModX In ActiveWorkbook.VBProject.VBComponents
Set VBComp = ActiveWorkbook.VBProject.VBComponents(ModX.Name)
If ModX.Type = 100 Then
VBComp.CodeModule.DeleteLines 1, VBComp.CodeModule.CountOfLines
Else
ActiveWorkbook.VBProject.VBComponents.Remove VBComp
End If
Next

ActiveSheet.DrawingObjects.Delete

ActiveSheet.DrawingObjects.Delete
ActiveWorkbook.SaveAs Klasor & "\" & dosya_adi & uzanti, FileFormat:=51  '52 -4143
ActiveWorkbook.Close SaveChanges:=False

End Sub

 

[Gold_Savt]

Ekli resimde gösterdiğim gibi uyarı veriyor hocam.

 

[halit3]

Biyokrafinizde ofis 2007 kullandığınız yazıyor kodlar buna göre düzenlendi
Bu kod bu hatayı vermemesi lazım
yazdığım kodu içinde barındıran hata aldığınız dosyayı ekleyin bir bakalım.

 

[Gold_Savt]

Ofis 2010 kullanıyorum. Burada güncellemeyi unutmuşum.

 

[halit3]

örnek dosyanızı eklermisiniz.

 

[Gold_Savt]

Örnek dosya ektedir.

 

[halit3]

Yukarıdaki mesajımda bahsetmiştim kod ofis 2007 ve üzeri için yazılmıştır.
eklediğiniz dosyanın uzantısı xls yani ofis 2007 den aşağıdaki sürümler için kullanılır. ofis 2007 ve üzeri için xlsm makro içerir xlsx makro içermez.
bu doğrultuda kod xls içn böyle olmalı.
kırmızı yerlere dikkat ediniz.

Sub kayityap()

Klasor = CreateObject("wscript.Shell").SpecialFolders.Item("Desktop")
dosya_adi = "deneme15"

dosya = ThisWorkbook.FullName
uzanti = ".xls"
Sayfa_Adı = ActiveSheet.Name
ActiveSheet.Copy


For Each ModX In ActiveWorkbook.VBProject.VBComponents
Set VBComp = ActiveWorkbook.VBProject.VBComponents(ModX.Name)
If ModX.Type = 100 Then
VBComp.CodeModule.DeleteLines 1, VBComp.CodeModule.CountOfLines
Else
ActiveWorkbook.VBProject.VBComponents.Remove VBComp
End If
Next

ActiveSheet.DrawingObjects.Delete

ActiveSheet.DrawingObjects.Delete
ActiveWorkbook.SaveAs Klasor & "\" & dosya_adi & uzanti, FileFormat:=-4143
ActiveWorkbook.Close SaveChanges:=False

End Sub

 

[Korhan Ayhan]

Alternatif;

Kendinize uyarlarsınız.

Option Explicit

Sub Test()
    Dim File_Path As String
   
    File_Path = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator
    ActiveSheet.Copy
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=File_Path & Format(Now, "nn ss") & " Çıktı.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    Application.DisplayAlerts = True
End Sub

 

[halit3]

Bu kod bütün sürümlerde çalışır.

Sub kayityap()

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

uzanti = fL.GetExtensionName(ThisWorkbook.FullName)

If uzanti = "xls" Then
FileFormatNum = -4143
ElseIf uzanti = "xlsm" Then
FileFormatNum = 52
ElseIf uzanti = "xlsx" Then
FileFormatNum = 51
ElseIf uzanti = "xlsb" Then
FileFormatNum = 50
Else
FileFormatNum = 56
End If

Klasor = CreateObject("wscript.Shell").SpecialFolders.Item("Desktop")
dosya_adi = "deneme15"

dosya = ThisWorkbook.FullName
Sayfa_Adı = ActiveSheet.Name
ActiveSheet.Copy

For Each ModX In ActiveWorkbook.VBProject.VBComponents
Set VBComp = ActiveWorkbook.VBProject.VBComponents(ModX.Name)
If ModX.Type = 100 Then
VBComp.CodeModule.DeleteLines 1, VBComp.CodeModule.CountOfLines
Else
ActiveWorkbook.VBProject.VBComponents.Remove VBComp
End If
Next

ActiveSheet.DrawingObjects.Delete
ActiveWorkbook.SaveAs Klasor & "\" & dosya_adi & "." & uzanti, FileFormat:=FileFormatNum
ActiveWorkbook.Close SaveChanges:=False

End Sub

 

[Gold_Savt]

Alternatif;

Kendinize uyarlarsınız.

Option Explicit

Sub Test()
    Dim File_Path As String
   
    File_Path = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator
   
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=File_Path & Format(Now, "nn ss") & " Çıktı.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    Application.DisplayAlerts = True
End Sub

Sayın Korhan Bey; Sadece Aktif çalışma sayfasını aktarsa kafi gelecek hocam. Verdiğiniz kodda tüm sayfalar aktarılıyor.
Sayın Halit Bey, Kodlarınızı ben çalıştıramadım. Dediğiniz gibi sürüm uyuşmazlığı olmalı.

 

[Korhan Ayhan]

Sizin kullandığınız kod satırından yola çıkarak cevap vermiştim. Önerdiğim koda küçük bir ekleme yaptım. Tekrar deneyiniz.

 

[Gold_Savt]

Teşekkürler Korhan Bey. Sağlıklı çalışıyor.
Kopyalama sırasında sadece .value değerlerini kopyalama imkanı var mı? Şu haliyle de güzel ancak .formula değerler olunca ilerde bozulma durumu olabilir. Tekrar teşekkürler

Düzeltme Notu: Aşağıdaki kod ile hallettim.

Range("ilgili hücreler") = Range("ilgili hücreler").Value

 

[Korhan Ayhan]

Bu taleplerinizi ilk mesajınızda belirtirseniz konunuzla ilgilenenlerin vakitlerini çalmamış olursunuz.

 

[Gold_Savt]

Plansızlıktan kaynaklanıyor. Bir işi bitiriyorsunuz, diğeri çıkıyor.