Bu makrolar nasıl birleştirilir?

[Tevfik_Kursun]

Merhaba Arkadaşlar,

Option Explicit

Sub Dosyalardaki_Adlari_Temizle()
    Dim Yol As String
    Dim Dosya As String
    Dim Hedef_Dosya As Workbook
    
    Yol = ThisWorkbook.Path
    
    On Error Resume Next
    Dosya = Dir(Yol & "\*.xls")
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    While Dosya <> ""
        If Dosya <> "TEST.xls" Then
            DoEvents
            Set Hedef_Dosya = Workbooks.Open(Yol & "\" & Dosya, False, False)
            
            With Hedef_Dosya
                For Each Ad In .Names
                    Ad.Delete
                Next
            End With
            
            Hedef_Dosya.Close True
        End If
        Dosya = Dir
    Wend
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    MsgBox "Klasördeki tüm dosyalarınızdaki ad tanımlamaları temizlenmiştir.", vbInformation
End Sub

Yukarıdaki tag içindeki kod, Korhan Ayhan Hocamın 21.02.2014 te hazırladığı koddur ve klasör içinde bulunduğu dosya dışındaki dosyaları kontrol eder ve sayfaların altındaki makroları temizler.
Aşağıdaki tag içinde ise Hüseyin Çoban Hocamın dosya içinde bulunan bir sayfayı dışarıya farklı bir dosya olarak atar.
Hangi satırları nasıl değiştirmeliyim ki içinde bulunduğu dosyanın belli sayfasını yeni bir dosya olarak kayıt etmeden dosya içindeki makroları da temizlesin?

Sub DosyayaYaz()
    ActiveSheet.Unprotect "111"
    
    SyfAdi = Cells(1, 14)
    HngSyf = Cells(1, 2)
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Sheets(HngSyf).Copy After:=Sheets(Sheets.Count)
    ActiveWindow.Zoom = 90
    ActiveSheet.Shapes.Range(Array("CommandButton1")).Delete
    ActiveSheet.Shapes.Range(Array("CommandButton2")).Delete
    ActiveSheet.Shapes.Range(Array("CommandButton3")).Delete
    ActiveSheet.Shapes.Range(Array("CommandButton4")).Delete
    ActiveSheet.Shapes.Range(Array("CommandButton5")).Delete
    
    aa = ActiveSheet.PageSetup.PrintArea
    Range(aa).Select
    
    With Selection
        ilk_sat = .Row
        ilk_adres = Split(.Address, "$")(1)
        son_adres = Split(.Address, "$")(3)
        ilk_adres = Split(Cells(1, Columns(ilk_adres).Column - 1).Address, "$")(1)
        son_adres = Split(Cells(1, Columns(son_adres).Column + 1).Address, "$")(1)
    End With
    
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    
    Range("A1").Select
    
    Columns(son_adres & ":AI").Delete Shift:=xlToLeft
    Rows("1:" & ilk_sat - 1).Delete Shift:=xlUp
    Columns("A:" & ilk_adres).Delete Shift:=xlToLeft
    
    Yol = ThisWorkbook.Path & "\"
    isim = SyfAdi
    ActiveSheet.Copy
    Application.Goto Reference:=Range("a1"), Scroll:=True
    ActiveWorkbook.SaveAs Filename:=Yol & isim & ".xls", FileFormat:=xlExcel8, CreateBackup:=False
    ActiveSheet.Name = isim
    ActiveWindow.Close True
    ActiveSheet.Delete
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Range("A1").Select
    ActiveSheet.Protect "111"
End Sub

Saygılarımla

 

[vardar07]

Birinci makrodaki :
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Klasördeki tüm dosyalarınızdaki ad tanımlamaları temizlenmiştir.", vbInformation"
pasif hale getirip End Sub dan önce Call DosyayaYaz yazıp,
İkinci makrodaki:
Application.ScreenUpdating = False
Application.DisplayAlerts = False
satırlarını pasif hale getirerek deneyiniz.

 

[Tevfik_Kursun]

İlginize çok teşekkür ederim Sayın Vardar07 arkadaşım,

Compile error:
Variable not defined

şeklinde bir hata veriyor. Kendi bastığı dosyanın adını bulamıyor. Adı sabit hale getirdiğimde başka sorunlar oluşacak diye düşünüyorum. O nedenle karar veremedim.
Saygılarımla

 

[dEdE]

Merhaba,
Kodlarınızın en başındaki

Option Explicit

satırını silerseniz o hatayı vermez ama bunu önermiyorum.
Bunun yerine kullandığınız değişkenleri yine kodların başında gördüğünüz "Dim..." ile başlayan satırlardaki gibi tanımlamanız halinde bu hatayı almayacaksınız.

 

[Tevfik_Kursun]

Merhaba Arkadaşlar,
Sayfayı makrosuz ve düğmesiz olarak kopyalamayı başardım. Şimdi hedefim bu sayfayı bir dosyaya kaydedip sayfayı silmeyi başarmak. Umarım onu da başarırım.
Hepinize yardımlarınız için teşekkür ederim.
Saygılarımla

 

[vardar07]

Sizin adınıza sevindim. Ancak sizde çözümü açıklayıp aynı sorunu yaşayacak arkadaşlara yardımınız olsa iyi olmazmı?

 

[Tevfik_Kursun]

Tamamlamadan mı?
Saygılarımla

 

[Tevfik_Kursun]

Merhaba Arkadaşlar,
Aşağıdaki kodlardan ilki, makrolu sayfayı makrosuz olarak kopyalamaya, ikincisi ise bu makrosuz sayfayı dosya olarak dışarı atıp kendini silmeye yarıyor. Biraz yordu beni ama çözüldü. Güle güle kullanınız.
Saygılarımla

Sub SayfaKopyala()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Dim Sayfa As Worksheet
    Dim SayfaAdi As String
    
        SayfaAdi = Cells(1, 14)
        HngSyf = Cells(1, 3)
        
        Sheets.Add.Name = SayfaAdi
        Sheets(SayfaAdi).Move After:=Sheets(Sheets.Count)
    
        Sheets(HngSyf).Range("A:AG").Copy Sheets(SayfaAdi).Range("A1")
        
        With Sheets(SayfaAdi).UsedRange
            .Value = .Value
        End With
End Sub

Sub YazDosyaya()

    SyfAdi = Cells(1, 14)
    
    Sheets(SyfAdi).Activate
    Rows("1:9").Delete Shift:=xlUp
    Columns("A:R").Delete Shift:=xlToLeft
    Range("A2").Select
        
    Yol = ThisWorkbook.Path & "\"
    isim = SyfAdi
    ActiveSheet.Copy
    
    ActiveWorkbook.SaveAs Filename:=Yol & isim & ".xls", FileFormat:=xlExcel8, CreateBackup:=False

    ActiveSheet.Name = isim
    ActiveWindow.Close True
    
    ActiveSheet.Delete
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

 

[kemalist]

Sub DOSYA ()
Dosyalardaki_Adlari_Temizle
Dosyaya Yaz
End Sub

Bu kodla iki kodu birlikte çalıştırabilirsiniz.