Klasör ve iç içe devam eden alt klasörleri sıralama

[muyat]

Görevliler isimli bir klasörde, çalışan kişilerin isimleri verilen alt klasörler var ve isimlere ait alt klasörlerin her birinin içine, hergün bir alt klasör ekleniyor..Bu eklenen alt klasörlere de isim olarak eklendiği günün tarihi yazılıyor.Örnegin 05.04.2020 .Ve bu her gün eklenen tarih isminin yazılı oldugu alt klasörlerin içinde de işyeri isimleri olan alt klasörler var..Onların içinde de dosyalar ve evraklar var....Mesela yarın bana 06.04.2020 isimli bir klasör eklenecek.İçinde işyerlerine ait kaç alt klasör var bilmiyorum..
Ama makro çalışınca mesela bir başkasına, yarın 06.04.2020 isimli klasör eklenmezse o sütuna karşılık gelen ilgili kişiye ait satırdaki hücre boş kalcak..Örnegin aşagıdaki Ahmet isimli kişiye 07.04.2020 klasör gönderilmeyecek.
Bu şekilde klasör ve alt klasör sıralamasını nasıl yapabiliriz makro ile?Yardımcı olur musunuz?

 

[halit3]

Bendeki klasörü ekliyorum kodların sonucu böyle çıkıyor.

Dim dosya
Dim sut
Dim tarih
Sub verial()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Klasörü Seçin", 50, &H0)
If Klasor Is Nothing Then Exit Sub
Kaynak = Klasor.self.Path
Cells.ClearContents
Cells(1, 1) = "İSİMLER"
sut = 1
For Each f In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).subfolders
sut = sut + 1
Cells(1, sut) = f.Name
tarih = f.Name
For Each ft In CreateObject("Scripting.FileSystemObject").GetFolder(f.Path).subfolders
dosya = ft.Name
Liste (ft.Path)
Next
Next
son1 = Worksheets(ActiveSheet.Name).Cells(Rows.Count, "a").End(3).Row
son2 = Worksheets(ActiveSheet.Name).Cells(1, Columns.Count).End(xlToLeft).Column
Range(Cells(2, 1), Cells(son1, son2)).Sort Key1:=Cells(2, 1), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

MsgBox "işlem tamam"

End Sub


Private Sub Liste(yol As String)

Dim fL As Object, fc As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki
For Each fc In fL.GetFolder(yol).subfolders
j = WorksheetFunction.CountA(Range("A1:A" & Rows.Count)) + 1
For s = 2 To Worksheets(ActiveSheet.Name).Cells(1, Columns.Count).End(xlToLeft).Column
If tarih = Cells(1, s) Then
Cells(j, sut) = fc.Name
End If
Next s
Cells(j, 1) = dosya
On Error Resume Next
Liste (fc.Path)
sonraki:
Next
Set fL = Nothing

End Sub

 

[muyat]

Halit hocam .Çok teşekkür ederim.Tam istedigim gibi.
Ama sizin eke koydugunuz dosyada klasörler : Tarih-İsim-İşyeri şeklinde iç içe ilerliyor...
Benim eke koydugum dosyada ise klasörler iç içe İsim-Tarih-İşyerleri şeklinde ilerliyor..Ve sıralama aynen eklediginiz resimdeki gibi olcak şekilde kodları düzenler misiniz.

 

[halit3]

Bu kodu bir dene

Dim dosya
Dim sut
Dim tarih

Sub verial3()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Klasörü Seçin", 50, &H0)
If Klasor Is Nothing Then Exit Sub
Kaynak = Klasor.self.Path
Cells.ClearContents
sat = 0
Cells(1, 1) = "İSİMLER" ': Cells(1, 2) = "ŞEHİRLER"
sut = 1
For Each f In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).subfolders

sat = CreateObject("Scripting.FileSystemObject").GetFolder(f.Path).subfolders.Count

For Each ft In CreateObject("Scripting.FileSystemObject").GetFolder(f.Path).subfolders

If sut > sat Then sut = 1
sut = sut + 1
Cells(1, sut) = ft.Name
tarih = ft.Name
dosya = f.Name
Liste (ft.Path)

Next
Next

son1 = Worksheets(ActiveSheet.Name).Cells(Rows.Count, "a").End(3).Row
son2 = Worksheets(ActiveSheet.Name).Cells(1, Columns.Count).End(xlToLeft).Column

Range(Cells(2, 1), Cells(son1, son2)).Sort Key1:=Cells(2, 1), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

MsgBox "işlem tamam"

End Sub


Private Sub Liste(yol As String)

Dim fL As Object, fc As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki

For Each fc In fL.GetFolder(yol).subfolders
j = WorksheetFunction.CountA(Range("A1:A" & Rows.Count)) + 1

Cells(j, 1) = dosya
For s = 2 To Worksheets(ActiveSheet.Name).Cells(1, Columns.Count).End(xlToLeft).Column
If tarih = Cells(1, s) Then
'jj = WorksheetFunction.CountA(Range(Cells(1, s), Cells(Rows.Count, s))) + 1
Cells(j, sut) = fc.Name
End If
Next s

On Error Resume Next
Liste (fc.Path)
sonraki:
Next
Set fL = Nothing

End Sub

 

[halit3]

Yukarıdaki mesajdaki kod belki hata verebilir birde bunu dene

Dim dosya1
Dim tarih

Sub verial4()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Klasörü Seçin", 50, &H0)
If Klasor Is Nothing Then Exit Sub
Kaynak = Klasor.self.Path

Cells.ClearContents
sat = 0
Cells(1, 1) = "İSİMLER"
For Each f In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).subfolders
For Each ft In CreateObject("Scripting.FileSystemObject").GetFolder(f.Path).subfolders
aranan1 = ft.Name
For i = 2 To Worksheets(ActiveSheet.Name).Cells(1, Columns.Count).End(xlToLeft).Column
If aranan1 = Cells(1, i) Then
End If
Next i

deg = 0
For s = 2 To Worksheets(ActiveSheet.Name).Cells(1, Columns.Count).End(xlToLeft).Column
If ft.Name = Cells(1, s) Then
Cells(1, s) = ft.Name
deg = 1
End If
Next s

If deg = 0 Then
Cells(1, Worksheets(ActiveSheet.Name).Cells(1, Columns.Count).End(xlToLeft).Column + 1) = ft.Name
End If

tarih = ft.Name
dosya1 = f.Name
Liste (ft.Path)
Next
Next

MsgBox "işlem tamam"

End Sub


Private Sub Liste(yol As String)

Dim fL As Object, fc As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki
For Each fc In fL.GetFolder(yol).subfolders
j = WorksheetFunction.CountA(Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = dosya1
For s = 2 To Worksheets(ActiveSheet.Name).Cells(1, Columns.Count).End(xlToLeft).Column
If tarih = Cells(1, s) Then
Cells(j, s) = fc.Name
End If
Next s
On Error Resume Next
Liste (fc.Path)
sonraki:
Next
Set fL = Nothing

End Sub

 

[muyat]

Hocam teşekkürler.Ben programın 2.bölümünde
Columns("A:sut").AutoFit özelliği de ekledim.Böylelikle sutunlar otomatik açılıyor.
Yalnız bir diger problem şu:Ben bu kodu şekillerden dikdörtgeni seçerek ona tanımladım..Fakat tam emin değilim ama sütun sayısı arttıkça zamanla dikdörtgen şekil sağ tarafa dogru ilerleyip yeri değişebilir.Bunun yerini de sabitleyebilir misiniz.
Son olarak hep bu şekilde konu açmakla olmuyor.Bu işi nerden ve nasıl ögrendiniz?Tavsiyeniz nedir kitaplardan falan?Nerden başlamalıyız bu işe.

Dim dosya
Dim sut
Dim tarih

Sub Dikdörtgen2_Tıkla()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Klasörü Seçin", 50, &H0)
If Klasor Is Nothing Then Exit Sub
Kaynak = Klasor.self.Path
Cells.ClearContents
sat = 0
Cells(1, 1) = "İSİMLER" ': Cells(1, 2) = "ŞEHİRLER"

sut = 1
For Each f In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).subfolders

sat = CreateObject("Scripting.FileSystemObject").GetFolder(f.Path).subfolders.Count

For Each ft In CreateObject("Scripting.FileSystemObject").GetFolder(f.Path).subfolders

If sut > sat Then sut = 1
sut = sut + 1
Cells(1, sut) = ft.Name
tarih = ft.Name
dosya = f.Name
Liste (ft.Path)

Next
Next

son1 = Worksheets(ActiveSheet.Name).Cells(Rows.Count, "a").End(3).Row
son2 = Worksheets(ActiveSheet.Name).Cells(1, Columns.Count).End(xlToLeft).Column

Range(Cells(2, 1), Cells(son1, son2)).Sort Key1:=Cells(2, 1), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

MsgBox "işlem tamam"

End Sub


Private Sub Liste(yol As String)

Dim fL As Object, fc As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki

For Each fc In fL.GetFolder(yol).subfolders
j = WorksheetFunction.CountA(Range("A1:A" & Rows.Count)) + 1
Columns("A:sut").AutoFit
Cells(j, 1) = dosya
For s = 2 To Worksheets(ActiveSheet.Name).Cells(1, Columns.Count).End(xlToLeft).Column
If tarih = Cells(1, s) Then
'jj = WorksheetFunction.CountA(Range(Cells(1, s), Cells(Rows.Count, s))) + 1
Cells(j, sut) = fc.Name
End If
Next s

On Error Resume Next
Liste (fc.Path)
sonraki:
Next
Set fL = Nothing

End Sub

 

[Haluk]

........
......
dikdörtgen şekil sağ tarafa dogru ilerleyip yeri değişebilir.Bunun yerini de sabitleyebilir misiniz.
...
..

Şeklin üzerinde sağ tıklayın, Biçimlendir>> Özellikler >"Don't move or size - Yer değiştirmesin (?)" falan gibi bir seçenek olması lazım...

.

 

[Korhan Ayhan]

Bir kaç tavsiyeyi linkte bulabilirsiniz.

Makro yazmak nasıl öğrenilir?

Merhaba üstadlar, uzun zamandır excel kullanıcısıyım excel deki yerleşik fonksiyonlarla yaptığım çalışmalara kendimce hakimim. Biliyorsunuz ki fonsiyonlar bir yere kadar ihtiyaçlara cevap verebiliyor neyse ki excel de VBA gibi bir nimet var ve iyi ki excel.web.tr var fonksiyonların yeterli...

www.excel.web.tr

 

[muyat]

Tekrar merhaba.
Şöyle bir sorun var bu sefer.
Aşagıdaki veri3 isimli klasörde bu işlemi uyguladıgımda veri3 ün içindeki alt klasöre sahip olmayan kişilerin adları 1.sutunda gözükmüyor..Yani kişinin ana klasörde adı bulunabilir ama alt klasörü daha verilmemiş olabilir.
Kodları yeniden düzenleyebilir misiniz.

Mesela Excell listesinde Veli,Samet,Ramizin ismi çıkmıyor...Şayet bunlara alt klasör atanmamışsa 1.sutunun en altında da bunların isimleri çıkmalı.

Dim dosya
Dim sut
Dim tarih







Sub Dikdörtgen2_Tıkla()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Klasörü Seçin", 50, &H0)
If Klasor Is Nothing Then Exit Sub
Kaynak = Klasor.self.Path
Cells.ClearContents
sat = 0
Cells(1, 1) = "İSİMLER" ': Cells(1, 2) = "ŞEHİRLER"

sut = 1
For Each f In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).subfolders

sat = CreateObject("Scripting.FileSystemObject").GetFolder(f.Path).subfolders.Count

For Each ft In CreateObject("Scripting.FileSystemObject").GetFolder(f.Path).subfolders

If sut > sat Then sut = 1
sut = sut + 1
Cells(1, sut) = ft.Name
tarih = ft.Name
dosya = f.Name
Liste (ft.Path)

Next
Next

son1 = Worksheets(ActiveSheet.Name).Cells(Rows.Count, "a").End(3).Row
son2 = Worksheets(ActiveSheet.Name).Cells(1, Columns.Count).End(xlToLeft).Column

Range(Cells(2, 1), Cells(son1, son2)).Sort Key1:=Cells(2, 1), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

MsgBox "işlem tamam"

End Sub


Private Sub Liste(yol As String)

Dim fL As Object, fc As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki

For Each fc In fL.GetFolder(yol).subfolders
j = WorksheetFunction.CountA(Range("A1:A" & Rows.Count)) + 1
Columns("A:sut").AutoFit
Cells(j, 1) = dosya
For s = 2 To Worksheets(ActiveSheet.Name).Cells(1, Columns.Count).End(xlToLeft).Column
If tarih = Cells(1, s) Then
'jj = WorksheetFunction.CountA(Range(Cells(1, s), Cells(Rows.Count, s))) + 1
Cells(j, sut) = fc.Name
End If
Next s

On Error Resume Next
Liste (fc.Path)
sonraki:
Next
Set fL = Nothing

End Sub

 

[halit3]

Yazmış olduğum kodlara geri dönüşünüz çok geç oluyor sonra ne yaptığımı unutuyorum.
kod:

Dim dosya1
Dim tarih

Sub verial4()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Klasörü Seçin", 50, &H0)
If Klasor Is Nothing Then Exit Sub
Kaynak = Klasor.self.Path

Cells.ClearContents
sat = 0
Cells(1, 1) = "İSİMLER"
For Each f In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).subfolders

For Each ft In CreateObject("Scripting.FileSystemObject").GetFolder(f.Path).subfolders
aranan1 = ft.Name
For i = 2 To Worksheets(ActiveSheet.Name).Cells(1, Columns.Count).End(xlToLeft).Column
If aranan1 = Cells(1, i) Then
End If
Next i

deg = 0
For s = 2 To Worksheets(ActiveSheet.Name).Cells(1, Columns.Count).End(xlToLeft).Column
If ft.Name = Cells(1, s) Then
Cells(1, s) = ft.Name
deg = 1
End If
Next s

If deg = 0 Then
Cells(1, Worksheets(ActiveSheet.Name).Cells(1, Columns.Count).End(xlToLeft).Column + 1) = ft.Name
End If

tarih = ft.Name
dosya1 = f.Name
Liste (ft.Path)
Next
If CreateObject("Scripting.FileSystemObject").GetFolder(f.Path).subfolders.Count = 0 Then
j = WorksheetFunction.CountA(Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = f.Name
End If

Next

MsgBox "işlem tamam"

End Sub


Private Sub Liste(yol As String)

Dim fL As Object, fc As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki
For Each fc In fL.GetFolder(yol).subfolders
j = WorksheetFunction.CountA(Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = dosya1

For s = 2 To Worksheets(ActiveSheet.Name).Cells(1, Columns.Count).End(xlToLeft).Column
If tarih = Cells(1, s) Then
Cells(j, s) = fc.Name
End If
Next s
On Error Resume Next
Liste (fc.Path)
sonraki:
Next
Set fL = Nothing

End Sub

 

[muyat]

Halit hocam alt klasör verilmeyen kişilerin adları listede çıkıyor fakat bu sefer karıştırdı..
Önceki mesajımdaki ekte Veli isimli kişinin alt klasörü olmamasına ragmen Makroyı çalıştırdıgımda Veli isimli kişiye klasör atanmış gibi başkasına ait klasörü listeliyor.Aynı şekilde Mustafa isimli kişide de aynı problem var.İsimlerle alt klasörler excellde eşleşmiyor.

 

[halit3]

Halit hocam alt klasör verilmeyen kişilerin adları listede çıkıyor fakat bu sefer karıştırdı..
Önceki mesajımdaki ekte Veli isimli kişinin alt klasörü olmamasına ragmen Makroyı çalıştırdıgımda Veli isimli kişiye klasör atanmış gibi başkasına ait klasörü listeliyor.Aynı şekilde Mustafa isimli kişide de aynı problem var.İsimlerle alt klasörler excellde eşleşmiyor.

9 nolu mesajda bunları yazmışsınız şimdide 11 nolu mesajınızda bunların olmamasını istiyorsunuz.

Aşagıdaki veri3 isimli klasörde bu işlemi uyguladıgımda veri3 ün içindeki alt klasöre sahip olmayan kişilerin adları 1.sutunda gözükmüyor..Yani kişinin ana klasörde adı bulunabilir ama alt klasörü daha verilmemiş olabilir.
Kodları yeniden düzenleyebilir misiniz.

Mesela Excell listesinde Veli,Samet,Ramizin ismi çıkmıyor...Şayet bunlara alt klasör atanmamışsa 1.sutunun en altında da bunların isimleri çıkmalı.

 

[muyat]

Evet malesef haklısınız.Daha dogrusu Ana klasörün içindeki bazı kişi isimlerinde alt klasörler yok.Ama onların da ismi çıkmalı.Onu bugun farkettim..
Dolaysıyla ana klasöre tıkladıktan sonra iç içe ilerleyen klasörler kime gitmiş,veya hiç alt klasör tanımlayan kişilerin bile adının çıkması gerekiyor.
Bu problem yüzünden mükerrer dosyalar hala bize zaman kaybettiriyor.

 

[halit3]

10 nolu mesajdaki kod sizin istediğinizi veriyor kodu denedirizmi.?

 

[muyat]

Hocam evet şimdi farkettim.Evet kod istedigim gibi çalışıyor.Çok teşekkür ederim tekrar.İç içe devam eden klasörlerde sizin kodlar gayet güzel çalışıyor.