vba klasör kod yardım

[kalibre101]

merhabalar çalıştıgım excel kitabının sheets(1).[F2] adresindeki tarihi kullanarak
D: Sürücüsü varsa D ye
yoksa C sürücüsüne
İşletme Proğramı\Günlük İşletme\2022\ocak
İşletme Proğramı\Günlük İşletme\2022\şubat
şeklinde 12 aylık klasör oluşturup çalıştığım kitabın kopyalarını içlerine atacak 12 adet 1 yıl
yardımcı olursanız sevinirim

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Created_Folder_And_Copy_Files()
    Dim FSO As Object, My_Date As Date, My_Path As String
    Dim My_Driver As String, My_Folder As String
    Dim My_File As String, X As Byte
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
   
    My_Date = Sheets(1).Range("F2").Value
    My_Path = "İşletme Proğramı\Günlük İşletme\"
   
    If FSO.DriveExists("D:\") = True Then
        My_Driver = "D:\"
    ElseIf FSO.DriveExists("C:\") = True Then
        My_Driver = "C:\"
    Else
        MsgBox "İşlem yapabileciğiniz sürücü bulunamadı!", vbCritical
        Exit Sub
    End If
       
    For X = 1 To 12
        My_Folder = My_Driver & My_Path & Year(My_Date) & "\" & _
                    Format(X, "00-") & Format(DateSerial(Year(My_Date), X, 1), "mmmm")
        If Len(Dir(My_Folder, vbDirectory)) = 0 Then
            Shell ("cmd /c mkdir """ & My_Folder & """")
        End If
        Do
            DoEvents
            My_File = Dir(My_Folder, vbDirectory)
        Loop While My_File = ""
        ActiveWorkbook.SaveCopyAs My_Folder & "\" & ActiveWorkbook.Name
    Next

    Set FSO = Nothing
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[kalibre101]

Deneyiniz.

Option Explicit

Sub Created_Folder_And_Copy_Files()
    Dim FSO As Object, My_Date As Date, My_Path As String
    Dim My_Driver As String, My_Folder As String, X As Byte
  
    Set FSO = CreateObject("Scripting.FileSystemObject")
  
    My_Date = Sheets(1).Range("F2").Value
    My_Path = "İşletme Proğramı\Günlük İşletme\"
  
    If FSO.DriveExists("D:\") = True Then
        My_Driver = "D:\"
    ElseIf FSO.DriveExists("C:\") = True Then
        My_Driver = "C:\"
    Else
        MsgBox "İşlem yapabileciğiniz sürücü bulunamadı!", vbCritical
        Exit Sub
    End If
      
    For X = 1 To 12
        My_Folder = My_Driver & My_Path & Year(My_Date) & "\" & _
                    Format(X, "00-") & Format(DateSerial(Year(My_Date), X, 1), "mmmm")
        If Len(Dir(My_Folder, vbDirectory)) = 0 Then
            Shell ("cmd /c mkdir """ & My_Folder & """")
        End If
        Application.Wait Now + TimeSerial(0, 0, 1)
        ActiveWorkbook.SaveCopyAs My_Folder & "\" & ActiveWorkbook.Name
    Next

    Set FSO = Nothing
  
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Çok teşekkürler sorunsuz çalışyor hayırlı işler dilerim

 

[kalibre101]

Deneyiniz.

Option Explicit

Sub Created_Folder_And_Copy_Files()
    Dim FSO As Object, My_Date As Date, My_Path As String
    Dim My_Driver As String, My_Folder As String, X As Byte
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
 
    My_Date = Sheets(1).Range("F2").Value
    My_Path = "İşletme Proğramı\Günlük İşletme\"
 
    If FSO.DriveExists("D:\") = True Then
        My_Driver = "D:\"
    ElseIf FSO.DriveExists("C:\") = True Then
        My_Driver = "C:\"
    Else
        MsgBox "İşlem yapabileciğiniz sürücü bulunamadı!", vbCritical
        Exit Sub
    End If
     
    For X = 1 To 12
        My_Folder = My_Driver & My_Path & Year(My_Date) & "\" & _
                    Format(X, "00-") & Format(DateSerial(Year(My_Date), X, 1), "mmmm")
        If Len(Dir(My_Folder, vbDirectory)) = 0 Then
            Shell ("cmd /c mkdir """ & My_Folder & """")
        End If
        Application.Wait Now + TimeSerial(0, 0, 1)
        ActiveWorkbook.SaveCopyAs My_Folder & "\" & ActiveWorkbook.Name
    Next

    Set FSO = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

korhan bey şu hatayı almaya başladım oysaki kodda hiç değişiklik yapmadım bazen çalışıyor bazen hata veriyor hata veren uyarıya end diyip tekrar çalıştırdımmı hata verdiği yeri oluşturuyor ilerledikçe tekrar hata veriyor end deyip tekrar çalıştırarak hepsini oluşturuyor

Deneyiniz.

Option Explicit

Sub Created_Folder_And_Copy_Files()
    Dim FSO As Object, My_Date As Date, My_Path As String
    Dim My_Driver As String, My_Folder As String, X As Byte
  
    Set FSO = CreateObject("Scripting.FileSystemObject")
  
    My_Date = Sheets(1).Range("F2").Value
    My_Path = "İşletme Proğramı\Günlük İşletme\"
  
    If FSO.DriveExists("D:\") = True Then
        My_Driver = "D:\"
    ElseIf FSO.DriveExists("C:\") = True Then
        My_Driver = "C:\"
    Else
        MsgBox "İşlem yapabileciğiniz sürücü bulunamadı!", vbCritical
        Exit Sub
    End If
      
    For X = 1 To 12
        My_Folder = My_Driver & My_Path & Year(My_Date) & "\" & _
                    Format(X, "00-") & Format(DateSerial(Year(My_Date), X, 1), "mmmm")
        If Len(Dir(My_Folder, vbDirectory)) = 0 Then
            Shell ("cmd /c mkdir """ & My_Folder & """")
        End If
        Application.Wait Now + TimeSerial(0, 0, 1)
        ActiveWorkbook.SaveCopyAs My_Folder & "\" & ActiveWorkbook.Name
    Next

    Set FSO = Nothing
  
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Korhan bey ekteki resimdeki hatayı veriyor bazen çalışıyor bazen hata veriyor end deyip kodu tekrar çalıştırdığımda hata veren kısmı oluşturuyor sonra kod ilerledikçe tekrar hata veriyor end tuşuna basıp tekrar çalıştırıyorum bu şekilde kod tamamlanıyor on error resume next uyguladıgımda
hata veren ay dosyası kaydedilmeden kodu tamamlıyor

hata.jpg

drive.google.com

yardımcı olabilirseniz memnun olurum

 

[Korhan Ayhan]

Kodda aslında bekleme komutu var. Yeteriz kalmış olabilir.

Paylaştığım kodda küçük bir revize yaptım. Son halini deneyiniz.

 

[kalibre101]

Kodda aslında bekleme komutu var. Yeteriz kalmış olabilir.

Paylaştığım kodda küçük bir revize yaptım. Son halini deneyiniz.

teşekkür ederim bu haliyle uyarı vermedi

 

[SaiL0704]

çok güzel bir çalışma, ben de faydalanmak isterim.
Fakat benim için biraz değişikliğe ihtiyaç var.
günlük rapor yazarken her günün kaydını tutabilirim bu şekilde

istediğim şey;
makroyu çalıştırdığım tarih baz alınsın ve sadece o ay klasörünün içine kaydetsin, diğerlerine kaydetmesin.
her gün bu işlemi yapacağım için, bir önceki gün kaydedilmiş dosyayı silmesin, yeni dosya kaydı yapsın.
dosyanın ismine ilave olarak o günün tarihini yazsın, ya da dosya isminin başına 1-,2-,3-,4-... diye günleri belirten bir rakam da koyulabilir.

 

[Korhan Ayhan]

Bahsettiğiniz dosyalar hangi klasöre kayıt edilecek? Yani dosya yolu belli mi?

 

[SaiL0704]

D: sürücüsü
ALSANCAK klasörü

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Created_Folder_And_Copy_Files()
    Dim FSO As Object, My_Date As Date, My_Path As String
    Dim My_Folder As String, My_File As String, X As Byte
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
   
    My_Date = Date
    My_Path = "D:\ALSANCAK\"
   
    My_Folder = My_Path & Year(My_Date) & "\" & _
                Format(Month(Date), "00-") & _
                Format(DateSerial(Year(My_Date), Month(Date), 1), "mmmm")
    If Len(Dir(My_Folder, vbDirectory)) = 0 Then
        Shell ("cmd /c mkdir """ & My_Folder & """")
    End If
    Do
        DoEvents
        My_File = Dir(My_Folder, vbDirectory)
    Loop While My_File = ""
    ActiveWorkbook.SaveCopyAs My_Folder & "\" & Day(Date) & "-" & ActiveWorkbook.Name

    Set FSO = Nothing
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[SaiL0704]

çalışıyor, çok teşekkür ederim ellerinize sağlık.