Yıllara Göre Otomatik Dosya Oluşturma

[KuTuKa]

Merhaba Arkadaşlar

Pandemi den dolayı artık evden çalışır olduk o yüzden yazıcıdan çıktı alıp dosya tutamıyoruz. Tüm kaydettiklerimiz bilgisayarda yer alıyor.

İstediğim Dijital bir arşiv nasıl olmalı ?

Bunun için siteden aşağadaki örneği buldum.Makronun Yapmasını istediğim.

Yıl Klasörlerini oluşturacak.
Yıl Sütununda yer alan Her Yıla 12 ay olarak dosya oluşturcak. 202101- 202102... 202112
Ay kısmında yer alan örnek 202101 içinde Alt Dosya İsmi Yazdığım Tüm isimler bir dosya olara yaratacak1-Askerlik Borçlanması 2Avans Ödemesi ..... olmalı ve

ek ödemeler içinde de Alt Dosya 1 Alt dosya 2 Alt dosya 3 olarak yazdığım Fazla mesai ve agi dosyası , fazla mesai ve Agi dosyasını oluşturmalı.



Alt dosya 3 e kadar yapılmış Alt Dosya 10 a kadar sütun ekleyebilirmiyiz


Excelde bulduğum örnek bir kısmını yapıyor ama hepsini iç içe attığından olmuyor.







Herkese şimdiden Teşkkürler

 

[ÖmerFaruk]

Klasör listesinin nasıl olacağını Kodların içinde belirttim.

Sub KlasörYap()
' Klasör tablonuda 1.satır Başlıklar olmalı
' ....
' A2 den başlamak üzere Ana klasör adı olan yılları belirtin
' ....
' Aylar standart olduğu için otomatik oluşacak
' ....
' B2 den başlamak üzere Alt klasör adlarını yazın
' ....
' C sütunundan itibaren C-D-E... diye devam ederek
' En alt klasörleri yazabilirsiniz.
' En alt klasörler için sınırlama yoktur. İstediğiniz sayda sağa doğru gidebilirsiniz.
' Tek kıstas boş bırakılan sütunda en alt klasör oluşumu sonlandırılır

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Klasörü Seçin", 5000, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
On Error Resume Next
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
For i = 2 To Cells(Rows.Count, "A").End(3).Row
    klasor1 = Cells(i, 1).Value
    If Dir(Kaynak & klasor1) = "" Then MkDir Kaynak & klasor1
    For ay = 1 To 12
        klasor2 = klasor1 & Format(ay, "00")
        If Dir(Kaynak & klasor1 & "\" & klasor2) = "" Then MkDir Kaynak & klasor1 & "\" & klasor2
        For b = 2 To Cells(Rows.Count, "B").End(3).Row
            klasor3 = Cells(b, 2).Value
            If Dir(Kaynak & klasor1 & "\" & klasor2 & "\" & klasor3) = "" Then MkDir Kaynak & klasor1 & "\" & klasor2 & "\" & klasor3
            x = 3
            Do Until Cells(b, x) = ""
                klasor4 = Cells(b, x).Value
                If Dir(Kaynak & klasor1 & "\" & klasor2 & "\" & klasor3 & "\" & klasor4) = "" Then MkDir Kaynak & klasor1 & "\" & klasor2 & "\" & klasor3 & "\" & klasor4
                x = x + 1
            Loop
        Next b
    Next ay
Next i

MsgBox "  Klasörler oluştu !", vbInformation, "DİKKAT"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

 

[KuTuKa]

Selamlar NextLevel

makroyu denedim ama ilk gönderdiğim makrolu dosyadan bir farkı olmadan çalıştı. Tekrar bakabilirmisiniz yada excel dosyasını gönderebilirmisiniz?

Çok Teşekkürler

 

[KuTuKa]

Çok Teşekkürler

olmuş

 

[onurbeyaz]

Çok Teşekkürler

Merhaba dosyanızı paylaşabilir misiniz rica etsem

 

[KuTuKa]

onurbeyaz
ektedir

 

[KuTuKa]

sayın @NextLevel

yıl içerisinde aylar olmadan da bir dosya yapabilirmiyiz?
202101
202102 gibi
Teşekkürler

 

[ÖmerFaruk]

sayın @NextLevel

yıl içerisinde aylar olmadan da bir dosya yapabilirmiyiz?
202101
202102 gibi
Teşekkürler

2021 klasörünün altında direkt alt dosya isimleri mi olsun?

 

[onurbeyaz]

onurbeyaz
ektedir

Çok teşekkür ederim,