Çalışma Sayfasını Ayrı Keydetme

[Hakan ERDOST]

Option Explicit
Sub DERS_DAĞILIMINI_AKTAR_2()
    Dim X1 As Integer, X2 As Integer, X3 As Integer
    Dim GÜN As String, BUL As Range
  
    Application.ScreenUpdating = False
    
    For X1 = 3 To Sayfa5.Cells(Rows.Count, "c").End(3).Row
     
If Rows(X1).Hidden = True Then GoTo 10

    If Sayfa5.Cells(X1, 10) <> 0 Then Sayfa6.Cells(X1, 1) = Sayfa5.Cells(X1, 3) Else GoTo 100:
     
    Sayfa6.Cells(X1, 2) = Sayfa5.Cells(X1, 10)
    
   
            For X3 = 18 To 50
                        
                        Sayfa6.Cells(X1, X3 - 15) = Sayfa5.Cells(X1, X3)
                  
            Next
100:
10:
        Next
        
Sayfa6.[a:a].SpecialCells(xlCellTypeBlanks).EntireRow.Delete

    Application.ScreenUpdating = True
 
    MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub

Bu kod ile Sayfa5 i aynı çalışma kitabında Sayfa6 ya aktarabiliyorum.Ancak istediğim şu Sayfay6 ya değilde C:/EKDERS altında yeni bir çalışma kitabında (Tercihen aktif ay ve gün adı ile) Sayfa1 e aktarmak için kodda nasıl bir revizyon gerekiyor.
Şimdiden teşekkürler.

 

[halit3]

kod:

Sub KAYITYAP()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Klasor = "C:\EKDERS"
If CreateObject("Scripting.FileSystemObject").FolderExists(Klasor) = False Then
MkDir Klasor
End If
uzanti = Right(ThisWorkbook.Name, InStr(1, StrReverse(ThisWorkbook.Name), ".", vbTextCompare) - 1)
dosya = Mid(ThisWorkbook.Name, 1, Len(ThisWorkbook.Name) - Len(uzanti) - 1)
Sheets("Sayfa5").Copy
Yedek_Dosya_Adı = dosya & Format(Now, " dd_mm_yyyy_hh_nn_ss") & "." & uzanti
Kayıt_Yeri = Klasor & "\" & Yedek_Dosya_Adı
ActiveWorkbook.SaveAs Kayıt_Yeri
ActiveWorkbook.Close False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[Hakan ERDOST]

Üstad Klasor satırında hata veriyor.

 

[halit3]

Üstad Klasor satırında hata veriyor.

Kod bende çalışıyor.

 

[halit3]

Birde bu kodu dene

kod:

Sub KAYITYAP()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
klasor = "C:\EKDERS"
If CreateObject("Scripting.FileSystemObject").FolderExists(klasor) = False Then
MkDir klasor
End If
uzanti = Right(ThisWorkbook.Name, InStr(1, StrReverse(ThisWorkbook.Name), ".", vbTextCompare))
If uzanti = ".xls" Then
FileFormatNum = -4143
ElseIf uzanti = ".xlsx" Then
FileFormatNum = 51
ElseIf uzanti = ".xlsm" Then
FileFormatNum = 52
ElseIf uzanti = ".xlsb" Then
FileFormatNum = 50
End If

dosya = Mid(ThisWorkbook.Name, 1, Len(ThisWorkbook.Name) - Len(uzanti) - 1)
Sheets("Sayfa5").Copy
Yedek_Dosya_Adı = dosya & Format(Now, " dd_mm_yyyy_hh_nn_ss") & uzanti
Kayıt_Yeri = klasor & "\" & Yedek_Dosya_Adı
ActiveWorkbook.SaveAs Kayıt_Yeri, FileFormat:=FileFormatNum
ActiveWorkbook.Close False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub