Farkli Kaydette Makrolarin TaŞinmamasi

[ckkaraca]

Yardımlarınız için şimdiden teşekkürler

Çok sayfalı Bir excel dosyasında makrolar kullandım.Bu makroların ve ilgili butonların farklı kaydet dediğimde kaydedeceği dosyaya taşınmasını istemiyorum.(Daha önce aynı dosyada,farklı kaydederken dosyanın sadece bir sayfasını kaydetmesi ve dosya ismi olarakta günün tarihi ile birlikte bir hücrede yazan ismi vermesi için bir makro kullanmıştım.Makroların kaydedeceğim sayfaya taşınmaması ile ilgili makroyuda bununla birlikte kullanacağım)Yardımınızı bekliyorum

 

[Levent Menteşoğlu]

Aşağıdaki prosedürü thisworkbook sayfasına kopyayın ve if koşulunun içine modülleri silen kodları yerleştirin.

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If SaveAsUI = True Then
.
.Modülleri silen kodlar
.
End If
End Sub

 

[ECYavuz]

Bu iş tehlikelidir. Dikkatli uygulayın...

Elimde bulunan bu konu ile ilgili kodu isterseniz deneyin ama. Çalışmanızın bir örneğini almayı unutmadan...

Sub farklıkaydet()
Dim vFilename As Variant
Dim wbActiveBook As Workbook
Dim oVBComp As Object
Dim oVBComps As Object

vFilename = Application.GetSaveAsFilename(filefilter:="Microso ft Excel Workbooks,*.xls", _
Title:="Save Copy Without Macros")
If vFilename = False Then Exit Sub
ActiveWorkbook.SaveCopyAs vFilename
Set wbActiveBook = Workbooks.Open(vFilename)
Set VBComps = ActiveWorkbook.VBProject.VBComponents
For Each VBComp In VBComps
Select Case VBComp.Type
Case 100
With VBComp.CodeModule
.DeleteLines 1, .CountOfLines
End With
Case Else
VBComps.Remove VBComp
End Select
Next VBComp
Set VBComps = Nothing
End Sub

 

[Arthassss]

Bu kodlara ilave olarak birde formüllerin oluşturulan yeni sayfaya değer olarak alınmasını sağlayabilirmiyiz?
Hücre biçimlendirmeleri vb.'lerininde değişmemesi gerekli.
Ve birde kitaba "a1" hücresindeki değeri ad olarak atayabilirmiyiz?

Elimde bulunan bu konu ile ilgili kodu isterseniz deneyin ama. Çalışmanızın bir örneğini almayı unutmadan...

Sub farklıkaydet()
Dim vFilename As Variant
Dim wbActiveBook As Workbook
Dim oVBComp As Object
Dim oVBComps As Object

vFilename = Application.GetSaveAsFilename(filefilter:="Microso ft Excel Workbooks,*.xls", _
Title:="Save Copy Without Macros")
If vFilename = False Then Exit Sub
ActiveWorkbook.SaveCopyAs vFilename
Set wbActiveBook = Workbooks.Open(vFilename)
Set VBComps = ActiveWorkbook.VBProject.VBComponents
For Each VBComp In VBComps
Select Case VBComp.Type
Case 100
With VBComp.CodeModule
.DeleteLines 1, .CountOfLines
End With
Case Else
VBComps.Remove VBComp
End Select
Next VBComp
Set VBComps = Nothing
End Sub