-
DİKKAT DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
"Alt Klasörleri" ve "Alt Klasörlerdeki Tüm Dosyaları" Listeleme
- Konbuyu başlatan leumruk
- Başlangıç tarihi
bende çok teşekkür ederim gerçekten çok yararlı bir paylaşım olmuş.. ama üstteki kodlara bir eklenti rica edeceğim.. bir türlü yapamadım..listelediğimiz klasörün içinde bulunan excellerde "Bottoms Summary sheet (inch)" adlı bir sheet var. Bu sheetlerin b28'deki değerini, oluşturduğumuz excelin I sütununa yazdırmak istiyorum.. yardımcı olursanız sevinirim...
Bu kodlar için çok teşekkür ediyorum, gerçekten çok işime yaradı.
Sadece bir şey daha eklemek istiyorum. Dosyaların boyutu, yaratma tarihi vb. bilgilerin yanında, dosyaların video olduğunu düşünün, video süresini getirmek istiyorum. Bunun için yardımcı olabilen olursa çok sevinirim.
Teşekkürler.
- Katılım
- 14 Şubat 2014
- Mesajlar
- 1
- Excel Vers. ve Dili
- 2010
Merhababalar, aşağıdaki kodlamada sabit bir klasörü seçtirmek mümkün müdür?
Kod:
Public ui As Long
Sub SubHsr()
Dim soru As String
101 Dim klsrSec As Object
102 Dim klsrMsUstu, Dosya, yol As String
103 Set klsrSec = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
104 klsrMsUstu = CreateObject("WScript.Shell").SpecialFolders("Desktop")
105 If klsrSec Is Nothing Then GoTo 117
106 If klsrSec = "Masaüstü" Or Klasor = "Desktop" Then
107 yol = klsrMsUstu
108 AnaListe (yol)
109 AltListe (yol)
110 ElseIf klsrSec <> "Masaüstü" Then
111 yol = klsrSec.Items.Item.Path
112 AnaListe (yol)
113 AltListe (yol)
114 Else
115 GoTo 117
116 End If
117 Set klsrSec = Nothing: ui = 0
End Sub
Private Sub AnaListe(yol As String)
201 Dim Dosya As String
202 Cells.ClearContents
203 Range("A4") = "Dosya Yolu": Range("B4") = "Dosya Adı"
206 Range("C4") = "Son Düzenleme Tarihi":
207 Dosya = Dir(yol & "\*.*")
208 ui = 4
209 While Dosya <> ""
210 DoEvents
211 ui = ui + 1
212 Cells(ui, 1) = yol
213 Cells(ui, 2) = Dosya
214 Call DosyaOzellikleri(yol & Application.PathSeparator & Dosya)
215 Dosya = Dir
216 Wend
End Sub
Private Sub AltListe(yol As String)
On Error Resume Next
301 Dim klsrAra, klsrLst As Object, Dosya, dsyTYl As String
302 Set klsrLst = CreateObject("Scripting.FileSystemObject").GetFolder(yol).SubFolders
303 On Error GoTo 316
304 For Each klsrAra In klsrLst
305 Dosya = Dir(klsrAra.Path & "\*.*")
306 While Dosya <> ""
307 DoEvents
308 ui = [a65000].End(3).Row + 1
309 Cells(ui, 1) = klsrAra.Path & "\"
310 Cells(ui, 2) = Dosya
311 Call DosyaOzellikleri(klsrAra.Path & Application.PathSeparator & Dosya)
312 Dosya = Dir
313 Wend
314 AltListe (klsrAra.Path)
315 Next
316 Set klsrAra = Nothing: Set klsrLst = Nothing
End Sub
Private Sub DosyaOzellikleri(dsyBak As String)
401 Dim DsSisKnt, Dosyam As Object
402 Set DsSisKnt = CreateObject("Scripting.FileSystemObject")
403 Set Dosyam = DsSisKnt.GetFile(dsyBak)
404 With Dosyam
405 ActiveSheet.Hyperlinks.Add Anchor:=Range("B" & ui), Address:=dsyBak
410 Range("C" & ui) = Format(.DateLastModified, "dd.mm.yyyy")
412 End With
413 Set DsSisKnt = Nothing
414 Set Dosyam = Nothing
End Sub- Katılım
- 27 Ekim 2017
- Mesajlar
- 97
- Excel Vers. ve Dili
- 2016 TÜRKÇE
- Altın Üyelik Bitiş Tarihi
- 06-01-2024
Halit bey sizin hedef klasörü kendimiz göstererek belirlediginiz kodlar daha çok begendım.
Ama istedigim şu:
Örngin masaüstüne yiyecekler isimli bir klasör var diyelim.İçinde de "meyveler,sebzeler,içecekler"isimli altklasörler var diyelim.Ben hedef olarak "yiyecekler"isimli klasörü seçince excell bana sıralama yaparken sadece"meyveler,sebzeler,içecekler"şeklinde sıralasın istiyorum.Sizin yöntemde c:\users dan başlayarak yazmaya başlıyor..Yani konumu yazmasın istiyorum..Buna uygun şekilde düzenler misiniz
Ama istedigim şu:
Örngin masaüstüne yiyecekler isimli bir klasör var diyelim.İçinde de "meyveler,sebzeler,içecekler"isimli altklasörler var diyelim.Ben hedef olarak "yiyecekler"isimli klasörü seçince excell bana sıralama yaparken sadece"meyveler,sebzeler,içecekler"şeklinde sıralasın istiyorum.Sizin yöntemde c:\users dan başlayarak yazmaya başlıyor..Yani konumu yazmasın istiyorum..Buna uygun şekilde düzenler misiniz
- Katılım
- 18 Ocak 2008
- Mesajlar
- 12,823
- Excel Vers. ve Dili
-
2003 excell türkçe
ve
2007 excell türkçe
Siz 4 nolu mesajdaki kodu diyorsanız 8 nolu mesajdaki yazılanıda dikkate alınız.
- Katılım
- 27 Ekim 2017
- Mesajlar
- 97
- Excel Vers. ve Dili
- 2016 TÜRKÇE
- Altın Üyelik Bitiş Tarihi
- 06-01-2024
Halit bey 8 nolu mesajda klasörün içindeki dosyaların yollarına kadar yazıyor.Benım istedigim bu değil
9 nolu mesajdaki kodlar bir klasörün içindeki alt klasörlerin içindeki dosyaları gösteriyor.
İstedigim şey seçtigim bir klasördeki sadece alt klasörlerin adlarını o alt klasörün konum ismini yazmayacak şekilde sadece klasör adı gözükcek şekilde yazdırmak
Yukarda anlattım.
Sizin yöntemde excele aktarınca c:\users\ali\yiyecekler\meyve "şeklinde başlayarak yazmaya başlıyor
Benım istedigim şey excele aktarınca sadece "meyve "yazcak.Basit örnek olsun diye ekledim.
9 nolu mesajdaki kodlar bir klasörün içindeki alt klasörlerin içindeki dosyaları gösteriyor.
İstedigim şey seçtigim bir klasördeki sadece alt klasörlerin adlarını o alt klasörün konum ismini yazmayacak şekilde sadece klasör adı gözükcek şekilde yazdırmak
Yukarda anlattım.
Sizin yöntemde excele aktarınca c:\users\ali\yiyecekler\meyve "şeklinde başlayarak yazmaya başlıyor
Benım istedigim şey excele aktarınca sadece "meyve "yazcak.Basit örnek olsun diye ekledim.
- Katılım
- 18 Ocak 2008
- Mesajlar
- 12,823
- Excel Vers. ve Dili
-
2003 excell türkçe
ve
2007 excell türkçe
Yazınızdan dosya değil klasörlerin listelenmesi anlaşılıyor.
Bu kod klasörün içindeki klasörleri (alt klasör dahil) A sutununa tam adresi B sutununa isimleri listeler
Bu kod klasörün içindeki klasörleri (alt klasör dahil) A sutununa tam adresi B sutununa isimleri listeler
Kod:
Sub CommandButton3_Click()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Range("A2:B65000").ClearContents
Liste11 (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste11(yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = yol & "\" & f.Name
Cells(j, 2) = f.Name
On Error Resume Next
Liste11 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub- Katılım
- 27 Ekim 2017
- Mesajlar
- 97
- Excel Vers. ve Dili
- 2016 TÜRKÇE
- Altın Üyelik Bitiş Tarihi
- 06-01-2024
Halit bey çok teşekkür ederim.Sizin kodda biraz düzenleme yaptım aşagıdaki gibi.Allah razı olsun sizden.Bütün iş yükümü azalttı diyebilirim.
Son bişey isticem...
Aşagıdaki kodlar bir klasör içindeki alt klasörleri a sutununa yazıyor...Adres kısımlarını ise eklemedim koddan sildim.
Ben son olarak şunu istiyorum.
Bir klasör içindeki alt klasörlerin alt klasörlerini sıralamak istiyorum...
Ama şöyle olacak.
Örnegin görevliler isimli bir klasör içinde alt klasörler var (ahmet,mehmet,ali,veli""şeklinde diyelim.
Bu görevlilerin oldugu alt klasörlerin içinde de kontrol edilecek mahallelelerin oldugu alt klasörler var diyelim...
Ben sizin bu programı çalıştırdıgım zaman ,soldaki a sutununa görevlilerin isim listesi yerleşcek.
B sutununa da mahalle adları yerleşcek...Böylece kim hangi mahalleye gitmiş filtremele ile bu
Son bişey isticem...
Aşagıdaki kodlar bir klasör içindeki alt klasörleri a sutununa yazıyor...Adres kısımlarını ise eklemedim koddan sildim.
Ben son olarak şunu istiyorum.
Bir klasör içindeki alt klasörlerin alt klasörlerini sıralamak istiyorum...
Ama şöyle olacak.
Örnegin görevliler isimli bir klasör içinde alt klasörler var (ahmet,mehmet,ali,veli""şeklinde diyelim.
Bu görevlilerin oldugu alt klasörlerin içinde de kontrol edilecek mahallelelerin oldugu alt klasörler var diyelim...
Ben sizin bu programı çalıştırdıgım zaman ,soldaki a sutununa görevlilerin isim listesi yerleşcek.
B sutununa da mahalle adları yerleşcek...Böylece kim hangi mahalleye gitmiş filtremele ile bu
Kod:
Sub Dikdörtgen2_Tıkla()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Range("A2:B65000").ClearContents
Liste11 (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste11(yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = f.Name
On Error Resume Next
Liste11 (f.Path)
sonraki:
Next
Columns("A").AutoFit
Set fL = Nothing
End Sub- Katılım
- 18 Ocak 2008
- Mesajlar
- 12,823
- Excel Vers. ve Dili
-
2003 excell türkçe
ve
2007 excell türkçe
Bu kodu bir dene
Kod:
Dim sut
Dim sat
Sub CommandButton3_Click()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Cells.ClearContents
Liste11 (Kaynak)
sat = 0
For r = 2 To Cells(Rows.Count, "A").End(3).Row
sut = 2
sat = sat + 1
aranan = Cells(r, "a").Value
Liste12 (aranan)
Next r
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste11(yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
For Each f In fL.GetFolder(yol).subfolders
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = yol & "\" & f.Name
Cells(j, 2) = f.Name
Next
Set fL = Nothing
End Sub
Private Sub Liste12(yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki
'sat = sat + 1
For Each f In fL.GetFolder(yol).subfolders
sut = sut + 1
Cells(sat, sut) = f.Name
On Error Resume Next
Liste12 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub- Katılım
- 27 Ekim 2017
- Mesajlar
- 97
- Excel Vers. ve Dili
- 2016 TÜRKÇE
- Altın Üyelik Bitiş Tarihi
- 06-01-2024
Kodda
'sat = sat + 1 yazdıgınız kısımda tırnak işaretini kaldırdım.Yine istedigim gibi çalışmıyor.
Ekte örnek bir klasör gönderdim
Görevliler isimli klasörün içinde 3 tane isim var .Ahmet-Ali-Mehmet
Ahmete ait alt klasörler:Eskişehir,İzmir,Konya,Manisa olmak üzere 4 tane
Mehmete ait alt klasörler: Ankara,Erzurum,Isparta,İstanbul,Yozgat olmak üzere 5 tane
Ali'ye ait alt klasörler:Aydın,ANTALYA,Muğla olmak üzere 3tane
Dolaysıyla ben makroyu çalıştırınca;
A sutununda önce ilk 3 satırda Ali yazcak ve B sütununda da Aliye karşılık gelen şehir isimleri,
sonraki ilk 4 satırda Ahmet yazıp B sutununda aynı satırlara karşılık gelen hücrelerde yine şehir isimleri,
sonraki ilk 5 satırda da Mehmet yazıp B sutununda aynı satırlara karşılık gelen hücrelerde yine şehir isimleri otomatık çıkmalı.
Aşagıdaki ovale tıklayıp görevliler isimli klasörü seçince kısaca aşagıdaki gibi sıralasın istiyorum.
'sat = sat + 1 yazdıgınız kısımda tırnak işaretini kaldırdım.Yine istedigim gibi çalışmıyor.
Ekte örnek bir klasör gönderdim
Görevliler isimli klasörün içinde 3 tane isim var .Ahmet-Ali-Mehmet
Ahmete ait alt klasörler:Eskişehir,İzmir,Konya,Manisa olmak üzere 4 tane
Mehmete ait alt klasörler: Ankara,Erzurum,Isparta,İstanbul,Yozgat olmak üzere 5 tane
Ali'ye ait alt klasörler:Aydın,ANTALYA,Muğla olmak üzere 3tane
Dolaysıyla ben makroyu çalıştırınca;
A sutununda önce ilk 3 satırda Ali yazcak ve B sütununda da Aliye karşılık gelen şehir isimleri,
sonraki ilk 4 satırda Ahmet yazıp B sutununda aynı satırlara karşılık gelen hücrelerde yine şehir isimleri,
sonraki ilk 5 satırda da Mehmet yazıp B sutununda aynı satırlara karşılık gelen hücrelerde yine şehir isimleri otomatık çıkmalı.
Aşagıdaki ovale tıklayıp görevliler isimli klasörü seçince kısaca aşagıdaki gibi sıralasın istiyorum.
- Katılım
- 18 Ocak 2008
- Mesajlar
- 12,823
- Excel Vers. ve Dili
-
2003 excell türkçe
ve
2007 excell türkçe
İsimler alt alta yazıyor şehirler isimlerin yanına yani sutun sutun yazıyor.
KOD:
KOD:
Rich (BB code):
Dim sut
Dim sat
Dim say
Dim veri(1000)
Sub CommandButton3_Click()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Cells.ClearContents
'Rows("2:500").ClearContents
Cells(1, 1) = "İSİMLER"
Cells(1, 2) = "ŞEHİRLER"
sut = 0
sat = 0
say = 0
Liste11 (Kaynak)
sat = 1
For r = 1 To say
sut = 1
sat = sat + 1
aranan = veri(r)
Liste12 (aranan)
Next r
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste11(yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
For Each f In fL.GetFolder(yol).subfolders
say = say + 1
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
veri(say) = yol & "\" & f.Name
Cells(j, 1) = f.Name
Next
Set fL = Nothing
End Sub
Private Sub Liste12(yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki
'sat = sat + 1
For Each f In fL.GetFolder(yol).subfolders
sut = sut + 1
Cells(sat, sut) = f.Name
On Error Resume Next
Liste12 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub- Katılım
- 18 Ocak 2008
- Mesajlar
- 12,823
- Excel Vers. ve Dili
-
2003 excell türkçe
ve
2007 excell türkçe
Bu kod 55 nolu mesajdaki sonuç ile aynı
PHP:
Dim say
Dim veri1(1000)
Dim veri2(1000)
Dim aranan2
Sub CommandButton3_Click()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Cells.ClearContents
'Rows("2:500").ClearContents
Cells(1, 1) = "İSİMLER"
Cells(1, 2) = "ŞEHİRLER"
say = 0
Liste11 (Kaynak)
For r = 1 To say
aranan1 = veri1(r)
aranan2 = veri2(r)
Liste12 (aranan1)
Next r
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste11(yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
For Each f In fL.GetFolder(yol).subfolders
say = say + 1
'j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
veri1(say) = yol & "\" & f.Name
veri2(say) = f.Name
Next
Set fL = Nothing
End Sub
Private Sub Liste12(yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = aranan2
Cells(j, 2) = f.Name
On Error Resume Next
Liste12 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub- Katılım
- 27 Ekim 2017
- Mesajlar
- 97
- Excel Vers. ve Dili
- 2016 TÜRKÇE
- Altın Üyelik Bitiş Tarihi
- 06-01-2024
Halit bey teşekkür ederim.Sizin kodlar istedigim gibi çalışıyor.
Başka bir ustad da şu şekilde yazdı.Paylaşıyorum...
Başka bir ustad da şu şekilde yazdı.Paylaşıyorum...
Kod:
Sub Oval3_Tıkla()
Columns("A:B").ClearContents
Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
If Klasor Is Nothing Then MsgBox "Klasör Seçmediniz", vbInformation + vbMsgBoxRtlReading, "İptal Edildi": Exit Sub
For Each ana In CreateObject("Scripting.FileSystemObject").GetFolder(Klasor.items.Item.Path).subfolders
For Each alt In CreateObject("Scripting.FileSystemObject").GetFolder(ana).subfolders
sat = sat + 1
Cells(sat + 1, 1) = ana.Name
Cells(sat + 1, 2) = alt.Name
Next alt, ana
Cells(1, 1).Resize(1, 2) = Array("İSİMLER", "ŞEHİRLER")
MsgBox "İşlem Tamamlandı",
End Sub