Klasör oluşturup içine çalışma sayfasını kaydetme

[kalibre101]

Çalıştığım excel dosyasında sayaç adinda sayfa var makroyu çalıştırdığımda D Sürücüsü icinde aylık yapılacaklar klasörü olusturup sayaç sayfasini kaydedecek eğer D sürücüsünde daha önce klasor ve sayaç dosyası olusturulduysa bu oluşturulmuş sayaç dosyasının son sayfasına kayıt yapacak amacım d icinde sayaç dosyası olusturup makroyu çalıştırdığımda son sayfaya kaydedecek ben her ay sayaç değeri aldiğimda makroyu çalıştıracağım daha önce kaydedilmiş sayaç dosyasının sonuna sayfami tasiyacagim
Yardımcı olabilirseniz çok sevinirim
Tesekkurler

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Kaydet()
    Dim Yol As String, WB As Workbook
    
    Application.ScreenUpdating = False
    
    Yol = "D:\Aylık Yapılacaklar\"
    
    If Dir(Yol, vbDirectory) = "" Then MkDir Yol
    
    If Dir(Yol & "Sayaç.xlsx") <> "" Then
        Set WB = Workbooks.Open(Yol & "Sayaç.xlsx", False, False)
        ThisWorkbook.Sheets("Sayaç").Copy After:=WB.Sheets(WB.Sheets.Count)
        With WB.Sheets(WB.Sheets.Count)
            .Unprotect "2227"
            .DrawingObjects.Delete
            .Protect "2227"
        End With
        WB.Close 1
    Else
        ThisWorkbook.Sheets("Sayaç").Copy
        With ActiveWorkbook.Sheets("Sayaç")
            .Unprotect "2227"
            .DrawingObjects.Delete
            .Protect "2227"
        End With
        ActiveWorkbook.SaveAs Yol & "Sayaç.xlsx"
        ActiveWorkbook.Close 0
    End If
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır."
End Sub

 

[kalibre101]

Deneyiniz.

Option Explicit

Sub Kaydet()
    Dim Yol As String, WB As Workbook
  
    Application.ScreenUpdating = False
  
    Yol = "D:\Aylık Yapılacaklar\"
  
    If Dir(Yol, vbDirectory) = "" Then MkDir Yol
  
    If Dir(Yol & "Sayaç.xlsx") <> "" Then
        Set WB = Workbooks.Open(Yol & "Sayaç.xlsx", False, False)
        ThisWorkbook.Sheets("Sayaç").Copy After:=WB.Sheets(WB.Sheets.Count)
        WB.Close 1
    Else
        ThisWorkbook.Sheets("Sayaç").Copy
        ActiveWorkbook.SaveAs Yol & "Sayaç.xlsx"
        ActiveWorkbook.Close 0
    End If
  
    Application.ScreenUpdating = True
  
    MsgBox "İşleminiz tamamlanmıştır."
End Sub

Çalışıyor çok teşekkür ederim yanlız ben söylemeyi unuttum kopyalarken sayfanın içinde nesnelerde var sayfanın şifresini kaldırıp onlarıda silmesi için ne yapabilirim
Sheets(Sayaç).Unprotect "2227"
ActiveSheet.Shapes.Range(Array( _
"Dikdörtgen: Üst Köşelerinden Biri Yuvarlatılmış, Biri Kesik 19")).Select
ActiveSheet.Shapes.SelectAll
Selection.Delete
ben böyle yapıyordum diğer işlemlerimde buna entegre edemedim
sayfanın şifresi 2227
yardımcı olursanız sevinirim

 

[Korhan Ayhan]

Paylaştığım kodu revize ettim. Kendinize uyarlarsınız.

 

[kalibre101]

Paylaştığım kodu revize ettim. Kendinize uyarlarsınız.

Mükemmel oldu teşekkür ederim çalışıyor.