"Alt Klasörleri" ve "Alt Klasörlerdeki Tüm Dosyaları" Listeleme

halit3 · 4 Nisan 2020

Kodu birazcık daha kısalttım

PHP:

Dim dosya

Sub deneme()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Klasörü Seçin", 50, &H0)
If Klasor Is Nothing Then Exit Sub
Kaynak = Klasor.self.Path
Columns("A:B").ClearContents
Cells(1, 1) = "İSİMLER": Cells(1, 2) = "ŞEHİRLER"
For Each f In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).subfolders
dosya = f.Name: Liste (Kaynak & "\" & f.Name)
Next
MsgBox "işlem tamam"

End Sub

Private Sub Liste(yol As String)

Dim fL As Object, f As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
j = WorksheetFunction.CountA(Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = dosya: Cells(j, 2) = f.Name
On Error Resume Next
Liste (f.Path)
sonraki:
Next
Set fL = Nothing

End Sub

TURKOLOG · 4 Nisan 2020

Sayın Halit Hocam affınıza sığınarak kodu kendime revize etmeye çalıştım ama olmadı
yapacağım işlemi alt klasörler dahil seçilen klasör ve altındaki klasörlere uygulamaya çalıştım ama olmadı
Ekli listede belirtiğim dosyada Açılmasını istediğim dosya ve klasörler için bir sabit yol zorunlu textboxa giriliyor . Her kaydet değidinde SABİTLER sayfasının B5 yoluna kaydedilecek şekilde
İsteğe bağlı 5 yolda yine SABİTLER sayfasının B6-10 aralığına kaydedilecek ama isteğe bağlı dosya ve klasör arama yolu dolu olmak zorunda değil

Klasör için mi Dosya için mi yoksa hem klasör hem dosya için mi arama yapılacağı seçildikten sonra Listele denince tercih neyse ona göre Listbox 1 ve ya 2 ye veya Listbox1-2 ye veri gelecek klasörse tıklayınca klasör açılacak dosya ise tıklayıca dosya türü ne ise o türden açılacak

Comcobox3 ve Combobox2 den de açılır menu şeklinde yol bulunabilecek

Textbox8 ve9 ile de Listbox1 ve 2 deki veri fazla olursa süzmeyi hedefliyorum ama işin içinden çıkamadım yardım ederseniz çok sevinirim.
Dosya Yolu

halit3 · 4 Nisan 2020

TURKOLOG' Alıntı:
Sayın Halit Hocam affınıza sığınarak kodu kendime revize etmeye çalıştım ama olmadı
yapacağım işlemi alt klasörler dahil seçilen klasör ve altındaki klasörlere uygulamaya çalıştım ama olmadı
Ekli listede belirtiğim dosyada Açılmasını istediğim dosya ve klasörler için bir sabit yol zorunlu textboxa giriliyor . Her kaydet değidinde SABİTLER sayfasının B5 yoluna kaydedilecek şekilde
İsteğe bağlı 5 yolda yine SABİTLER sayfasının B6-10 aralığına kaydedilecek ama isteğe bağlı dosya ve klasör arama yolu dolu olmak zorunda değil

Klasör için mi Dosya için mi yoksa hem klasör hem dosya için mi arama yapılacağı seçildikten sonra Listele denince tercih neyse ona göre Listbox 1 ve ya 2 ye veya Listbox1-2 ye veri gelecek klasörse tıklayınca klasör açılacak dosya ise tıklayıca dosya türü ne ise o türden açılacak

Comcobox3 ve Combobox2 den de açılır menu şeklinde yol bulunabilecek

Textbox8 ve9 ile de Listbox1 ve 2 deki veri fazla olursa süzmeyi hedefliyorum ama işin içinden çıkamadım yardım ederseniz çok sevinirim.
Dosya Yolu

Sayın TURKOLOG bu konu başlığı klasörleri ve dosyaları listelemek sizin sorunuz bu konu ile uyumlu değil farklı bir konu başlığı altında sorunuzu sorun.

muyat · 5 Nisan 2020

Halit hocam tekrar merhaba....Verdiginiz kodlar çalışıyor ama problem şu:
Ben Mehmete ait Alt klasörleri silince Listede Mehmet'in ismi çıkmıyor.Listede mehmetin adı da çıkcak ve ona ait alt klasör yoksa şehirler yazan sütundaki mehmete karşılık gelen satırın içi boş kalcak....Böylece Mehmete alt klasör verilmedigini anlıcaz.Bu dedigim şey bütün isimler için geçerli.Önceki arkadaşın yazdıgı kodlarda da bu problem var.
Bu arada şöyle bi değişiklik yaptık projede
Görevliler isimli bir klasörde, çalışan kişilerin isimlerinin oldugu 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 yarın klasör gönderilmeyecek.
Ve bu ekleme durumunun ne zaman bitecegi belli değil.1 ay da sürebilir, 1 yıl da...Ülkemizin içinde bulundugu duruma baglı. O nedenle sütun sayısında sınırlama olmamalı...
Bu problem yüzünden bazı işyerlerinin dağılımı,farklı tarihlerde birden fazla isime gidiyor anlaşılması zor oluyor....Gereksiz yere toner ve kagıt israfı oldugu gibi zaman kaybı oluyor...Böylece mükerrer olanları bulmaya çalışacagız
Yani bir örnek vercek olursam makro çalışınca aşagıdaki gibi olmalı.Mesela Ali isimli arkadaşa ayın 7sinde 0 7.04.2020 isimli bir alt klasör gönderilecek ve içinde RR Ve SS firması alt klasör var ve gruba o zaman dahil oluyor..Selami Bey'e 06.04.2020 tarihinde 06.04.2020 isimli alt klasör gönderilmemiş o nedenle ordaki hücre boş kalmış.07.04.2020 isimli hücrenin sağında bulunan hücrenin 08.04.2020 ismini alabilmesi için o isimdeki öyle bir klasörün listedeki isimlerden en az bir kişiye verilmiş olması gerekli. Ve yine 08.04.2020 tarihli klasörden Ahmete de verilirse ve içinde 10 firma adı varsa isimler yazan sütunda yukardan aşagıya 10 tane "Ahmet" yazması gerekir. 1 .satırdaki İSİMLER isimli hücre hariç diğer hücreler adlarını, isimlere eklenen alt klasörden alcak.Veya elle de yazarız.Sorun değil.Henüz makro yazmayı yeni yeni ögrendigim için problem beni aşıyor..Yardımlarınızı rica ediyorum

halit3 · 5 Nisan 2020

muyat' Alıntı:
Halit hocam tekrar merhaba....Verdiginiz kodlar çalışıyor ama problem şu:
Ben Mehmete ait Alt klasörleri silince Listede Mehmet'in ismi çıkmıyor.Listede mehmetin adı da çıkcak ve ona ait alt klasör yoksa şehirler yazan sütundaki mehmete karşılık gelen satırın içi boş kalcak....Böylece Mehmete alt klasör verilmedigini anlıcaz.Bu dedigim şey bütün isimler için geçerli.Önceki arkadaşın yazdıgı kodlarda da bu problem var.
Bu arada şöyle bi değişiklik yaptık projede
Görevliler isimli bir klasörde, çalışan kişilerin isimlerinin oldugu 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 yarın klasör gönderilmeyecek.
Ve bu ekleme durumunun ne zaman bitecegi belli değil.1 ay da sürebilir, 1 yıl da...Ülkemizin içinde bulundugu duruma baglı. O nedenle sütun sayısında sınırlama olmamalı...
Bu problem yüzünden bazı işyerlerinin dağılımı,farklı tarihlerde birden fazla isime gidiyor anlaşılması zor oluyor....Gereksiz yere toner ve kagıt israfı oldugu gibi zaman kaybı oluyor...Böylece mükerrer olanları bulmaya çalışacagız
Yani bir örnek vercek olursam makro çalışınca aşagıdaki gibi olmalı.Mesela Ali isimli arkadaşa ayın 7sinde 0 7.04.2020 isimli bir alt klasör gönderilecek ve içinde RR Ve SS firması alt klasör var ve gruba o zaman dahil oluyor..Selami Bey'e 06.04.2020 tarihinde 06.04.2020 isimli alt klasör gönderilmemiş o nedenle ordaki hücre boş kalmış.07.04.2020 isimli hücrenin sağında bulunan hücrenin 08.04.2020 ismini alabilmesi için o isimdeki öyle bir klasörün listedeki isimlerden en az bir kişiye verilmiş olması gerekli. Ve yine 08.04.2020 tarihli klasörden Ahmete de verilirse ve içinde 10 firma adı varsa isimler yazan sütunda yukardan aşagıya 10 tane "Ahmet" yazması gerekir. 1 .satırdaki İSİMLER isimli hücre hariç diğer hücreler adlarını, isimlere eklenen alt klasörden alcak.Veya elle de yazarız.Sorun değil.Henüz makro yazmayı yeni yeni ögrendigim için problem beni aşıyor..Yardımlarınızı rica ediyorum

Sayın muyat konu bütünlüğü bozulmaması için sorunuzu farklı bir konu başlığı altında yeni soru sorarak sorun bu konu başlığı klasör ve dosyaları listelemek sizin sorunuz bu duruma uymuyor.

konas06 · 7 Nisan 2020

halit3' Alıntı:

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

Hocam bu konu ile çok uğraşmışsınız belli ki, Ancak bu kodlamaya bir de köprüleme ekleyebilir miyiz?
Şimdiden teşekkür ederim.

halit3 · 7 Nisan 2020

konas06' Alıntı:
Hocam bu konu ile çok uğraşmışsınız belli ki, Ancak bu kodlamaya bir de köprüleme ekleyebilir miyiz?
Şimdiden teşekkür ederim.

Bu kod bir dene

Kod:

Dim dosya
Dim dosya2

Sub deneme()

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

Columns("A:B").Cells.Hyperlinks.Delete
Columns("A:B").Cells.Font.ColorIndex = 0

Cells(1, 1) = "İSİMLER": Cells(1, 2) = "ŞEHİRLER"
For Each f In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).subfolders
dosya2 = f.Path
dosya = f.Name: Liste (Kaynak & "\" & f.Name)
Next
MsgBox "işlem tamam"

End Sub

Private Sub Liste(yol As String)

Dim fL As Object, f As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
j = WorksheetFunction.CountA(Range("A1:A" & Rows.Count)) + 1
'Cells(j, 1) = dosya
Cells(j, 1).Hyperlinks.Add Anchor:=Cells(j, 1), Address:=dosya2, SubAddress:="" & firstAddress, TextToDisplay:=dosya  'fL.GetBaseName(Dir(Dosya))
'Cells(j, 2) = f.Name
Cells(j, 2).Hyperlinks.Add Anchor:=Cells(j, 2), Address:=f.Path, SubAddress:="" & firstAddress, TextToDisplay:=f.Name   'fL.GetBaseName(Dir(Dosya))
On Error Resume Next
Liste (f.Path)
sonraki:
Next
Set fL = Nothing

End Sub

halit3 · 7 Nisan 2020

konas06' Alıntı:
Hocam bu konu ile çok uğraşmışsınız belli ki, Ancak bu kodlamaya bir de köprüleme ekleyebilir miyiz?
Şimdiden teşekkür ederim.

Bu kodu bir dene

Theyakops · 10 Nisan 2020

Halit hocam ellerinize emeğinize sağlık konudaki tüm kodlarınızı tek tek denedim. Fakat ihtiyacım olanı tam bulamadım.
Benim talebim tam olarak şu şekilde; seçtiğim ana klasörden başlayarak içerisindeki; hem tüm alt klasörleri + hemde dosyaları listelemek istiyorum. İç içe hiç alt klasör ve dosya kalmayana dek tümünü listelemek.

Ve mümkünse windows kayıt defteri düzenleyicisinin dizin ağacında olduğu gibi; dosya + klasör isimleri yazılırken; alt dizindeki isimlerin her seferinde sağdaki bir alt hücreye yazılmasını istiyorum. (Eklediğim örnek resimdeki gibi, tabi mümkünse)

halit3 · 11 Nisan 2020

kod:

Kod:

Dim sayi
Dim sat

Sub klasör_dosya()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Klasörü Seçin", 50, &H0)
If Klasor Is Nothing Then Exit Sub
Kaynak = Klasor.self.Path
'Kaynak = ThisWorkbook.Path & "\deneme"
Cells.ClearContents
sat = 1
deg1 = Split(Kaynak, "\")
If UBound(deg1) > 0 Then
sayi = UBound(deg1)
End If
Liste (Kaynak)
MsgBox "işlem tamam"
End Sub
Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")

deg1 = Split(yol, "\")
If UBound(deg1) > 0 Then
sut = UBound(deg1) + 1 - sayi
End If

Cells(sat, sut) = fL.GetBaseName(yol) 'dosya.Name
sut = sut + 1
If fL.GetFolder(yol).Files.Count > 0 Then
For Each dosya In fL.GetFolder(yol).Files
sat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
Cells(sat, sut) = fL.GetBaseName(dosya.Name)  'dosya.Name
Next
End If
sat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

End Sub

aydogankemal · 25 Ekim 2022

leumruk' Alıntı:
Merhaba,
Excel 2003'te bulunan Filesearch ile alt klasörleri ve içlerinde bulunan dosyaları rahatlıkla listeleyebiliyorduk. Ancak 2007 ve 2010 sürümlerinde "Filesearch" kodunun çalışmamasından dolayı artık bu kod kullanışlı olma özelliğini yitirdi.

Bu nedenle Alt klasörleri ve alt klasörler içinde bulunan dosyaları listelemeye yarayan bir kod hazırladım. Ekteki Rarda bulunan klasörde örnek olması için alt klasörler ve içlerine rasgele dosyalar oluşturdum. Klasörü rardan çıkarıp deneme yapabilirsiniz. Umarım faydalı olur.

NOT: Kodlar alt klasörlerin içlerindeki tüm alt klasörleri ve bunların içinde bulunan tüm dosyaları listeler.

Sizinde konu hakkında alternatifleriniz varsa bu başlığa ekleyebilirsiniz.

Kod:

Sub Dosya_Listele() 'Tüm alt klasörlerdeki dosyaları listeler Set ds = CreateObject("Scripting.FileSystemObject") yol = ThisWorkbook.Path Columns(1).Clear Application.ScreenUpdating = False Do Tekrar: If ds.GetFolder(yol).subfolders.Count > 0 Then For Each kls In ds.GetFolder(yol).subfolders klslst = klslst & "{" & kls Next End If x = x + 1 deg = Split(klslst, "{") yol = deg(x) Dosya = Dir$(yol & "\*.*") Do While Dosya <> "" Say = Say + 1 Cells(Say, 1) = Dosya 'dosya yerine yol & "\" & dosya yazarsanız dosyalar yollarıyla birlikte listelenir. Dosya = Dir$() Loop If x = 1 And ds.GetFolder(yol).subfolders.Count > 0 Then GoTo Tekrar Loop While UBound(deg) <> x 'Kodlayan: l e u m r u k - mustafa altun End Sub

Rich (BB code):

Sub Klasör_Listele() 'Tüm alt klasörleri listeler Set ds = CreateObject("Scripting.FileSystemObject") yol = ThisWorkbook.Path Columns(1).Clear Application.ScreenUpdating = False Do Tekrar: If ds.GetFolder(yol).subfolders.Count > 0 Then For Each kls In ds.GetFolder(yol).subfolders klslst = klslst & "{" & kls Next End If x = x + 1 deg = Split(klslst, "{") yol = deg(x) Cells(x, 1) = deg(x) If x = 1 And ds.GetFolder(yol).subfolders.Count > 0 Then GoTo Tekrar Loop While UBound(deg) <> x 'Kodlayan: l e u m r u k - mustafa altun End Sub

Merhaba,
Kodlarınızla D klasörünü listelemek için aşağıdaki şekilde düzelttim, ama hata veriyor, nasıl bir düzeltme yapabilirim

Sub Klasör_Listele() 'Tüm alt klasörleri listeler
Set ds = CreateObject("Scripting.FileSystemObject")
yol = "D:\"
Columns(1).Clear
Application.ScreenUpdating = False
Do
Tekrar:
If ds.GetFolder(yol).subfolders.Count > 0 Then
For Each kls In ds.GetFolder(yol).subfolders
klslst = klslst & "{" & kls
Next
End If
x = x + 1
deg = Split(klslst, "{")
yol = deg(x)
Cells(x, 1) = deg(x)
If x = 1 And ds.GetFolder(yol).subfolders.Count > 0 Then GoTo Tekrar

Loop While UBound(deg) <> x

'Kodlayan: l e u m r u k - mustafa altun
End Sub

Hoksisamuray1 · 26 Eylül 2024

Merhabalar, Benim ekli kodum var. Burada B sütünündaki mağaza koduna göre ana dosya olan “Lokasyon Görseller” altındaki klasörlerin mağaza kodları uyuşanları buluyor ve bu klasörlere ait H sütunundaki ilgili hücreye link ekliyor.

Ama benim aslında yapmak istediğim B sütünündaki mağaza koduna göre ana dosya olan “Lokasyon Görseller” altındaki klasörlerin mağaza kodları uyuşanları bulsun. Bulduğu klasörler içinde dosya varmı baksın.
Eğer klasör bulunamazsa "Klasör Bulunamadı", klasör var ama görsel yoksa "Görsel Yok", görsel varsa "Görsel Var" şeklinde H sütunundaki ilgili hücreye not ve link eklensin istiyorum. Bu sayede linkini getirdiğim klasörlerden hangisinde görsel var veya yok bileyim. Buna konuda yardımcı olabilir misiniz?

Sub KlasorleriBulVeLinkEkle()
Dim ws As Worksheet
Dim cell As Range
Dim MagazaID As String
Dim lastModifiedFolder As String
Dim lastModifiedDate As Date

' Çalışma sayfasını tanımlayın (müşteri listesi olan sayfa)
Set ws = ThisWorkbook.Sheets("TR_RawData") ' Gerekirse sayfa adını güncelleyin

' Tarama yapılacak ana klasörleri tanımlayın
Dim klasorler(1 To 19) As String
klasorler(1) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\AVM\Aday"
klasorler(2) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\AVM\Aktif"
klasorler(3) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\AVM\Pasif"
klasorler(4) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Belediye\Aday"
klasorler(5) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Belediye\Aktif"
klasorler(6) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Belediye\Pasif"
klasorler(7) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Carrefour\Aday"
klasorler(8) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Carrefour\ Aktif"
klasorler(9) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Carrefour\ Pasif"
klasorler(10) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Koçtaş\Aday"
klasorler(11) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Koçtaş\Aktif"
klasorler(12) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Koçtaş\Pasif"
klasorler(13) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Migros\Aday"
klasorler(14) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Migros\Aktif"
klasorler(15) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Migros\Pasif"
klasorler(16) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Özel Mülk\Aday"
klasorler(17) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Özel Mülk\Aktif"
klasorler(18) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Özel Mülk\Pasif"
klasorler(19) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Seyhanlar\Pasif"

' B sütunundaki MağazaID'leri tarar (örneğin, B2'den başlar)
For Each cell In ws.Range("B2:B" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row)
MagazaID = cell.Value ' B sütunundaki MağazaID'yi alır

' En güncel klasör bilgilerini sıfırlayın
lastModifiedDate = 0
lastModifiedFolder = ""

' Her klasör yolu için arama yap
Dim i As Integer
For i = LBound(klasorler) To UBound(klasorler)
Call KlasorleriTara(klasorler(i), MagazaID, lastModifiedFolder, lastModifiedDate)
Next i

' En güncel klasör bulunduysa, H sütununa link ekle
If lastModifiedFolder <> "" Then
ws.Cells(cell.Row, "H").Hyperlinks.Add Anchor:=ws.Cells(cell.Row, "H"), _
Address:=lastModifiedFolder, TextToDisplay:="Klasör Linki"
Else
ws.Cells(cell.Row, "H").Value = "Klasör Bulunamadı"
End If
Next cell

MsgBox "Tüm MağazaID'ler için klasörlerde arama tamamlandı.", vbInformation
End Sub

' Alt klasörlerde tarama yapan rekürsif fonksiyon
Sub KlasorleriTara(klasorYolu As String, MagazaID As String, ByRef lastModifiedFolder As String, ByRef lastModifiedDate As Date)
Dim file As String
Dim folderPath As String
Dim folderDate As Date

' İlk olarak mevcut klasörde MağazaID ile başlayan klasörleri kontrol edin
file = Dir(klasorYolu & "\" & "*" & MagazaID & "*", vbDirectory)

Do While file <> ""
If (GetAttr(klasorYolu & "\" & file) And vbDirectory) = vbDirectory Then
folderPath = klasorYolu & "\" & file

' Klasörün gerçekten var olup olmadığını kontrol edin
If Dir(folderPath, vbDirectory) <> "" Then
' Klasörün son değiştirilme tarihini al
folderDate = FileDateTime(folderPath)

' Eğer bu klasör en güncel klasörse bilgileri sakla
If folderDate > lastModifiedDate Then
lastModifiedDate = folderDate
lastModifiedFolder = folderPath
End If
End If
End If

' Sonraki klasöre geç
file = Dir
Loop
End Sub

Hoksisamuray1 · 27 Eylül 2024

Hoksisamuray1' Alıntı:
Merhabalar, Benim ekli kodum var. Burada B sütünündaki mağaza koduna göre ana dosya olan “Lokasyon Görseller” altındaki klasörlerin mağaza kodları uyuşanları buluyor ve bu klasörlere ait H sütunundaki ilgili hücreye link ekliyor.

Ama benim aslında yapmak istediğim B sütünündaki mağaza koduna göre ana dosya olan “Lokasyon Görseller” altındaki klasörlerin mağaza kodları uyuşanları bulsun. Bulduğu klasörler içinde dosya varmı baksın.
Eğer klasör bulunamazsa "Klasör Bulunamadı", klasör var ama görsel yoksa "Görsel Yok", görsel varsa "Görsel Var" şeklinde H sütunundaki ilgili hücreye not ve link eklensin istiyorum. Bu sayede linkini getirdiğim klasörlerden hangisinde görsel var veya yok bileyim. Buna konuda yardımcı olabilir misiniz?

Sub KlasorleriBulVeLinkEkle()
Dim ws As Worksheet
Dim cell As Range
Dim MagazaID As String
Dim lastModifiedFolder As String
Dim lastModifiedDate As Date

' Çalışma sayfasını tanımlayın (müşteri listesi olan sayfa)
Set ws = ThisWorkbook.Sheets("TR_RawData") ' Gerekirse sayfa adını güncelleyin

' Tarama yapılacak ana klasörleri tanımlayın
Dim klasorler(1 To 19) As String
klasorler(1) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\AVM\Aday"
klasorler(2) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\AVM\Aktif"
klasorler(3) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\AVM\Pasif"
klasorler(4) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Belediye\Aday"
klasorler(5) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Belediye\Aktif"
klasorler(6) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Belediye\Pasif"
klasorler(7) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Carrefour\Aday"
klasorler(8) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Carrefour\ Aktif"
klasorler(9) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Carrefour\ Pasif"
klasorler(10) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Koçtaş\Aday"
klasorler(11) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Koçtaş\Aktif"
klasorler(12) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Koçtaş\Pasif"
klasorler(13) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Migros\Aday"
klasorler(14) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Migros\Aktif"
klasorler(15) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Migros\Pasif"
klasorler(16) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Özel Mülk\Aday"
klasorler(17) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Özel Mülk\Aktif"
klasorler(18) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Özel Mülk\Pasif"
klasorler(19) = "\\10.100.5.2\mora ortak\File System\Ortak\MORA GAYRIMENKUL\Lokasyon Görseller\Seyhanlar\Pasif"

' B sütunundaki MağazaID'leri tarar (örneğin, B2'den başlar)
For Each cell In ws.Range("B2:B" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row)
MagazaID = cell.Value ' B sütunundaki MağazaID'yi alır

' En güncel klasör bilgilerini sıfırlayın
lastModifiedDate = 0
lastModifiedFolder = ""

' Her klasör yolu için arama yap
Dim i As Integer
For i = LBound(klasorler) To UBound(klasorler)
Call KlasorleriTara(klasorler(i), MagazaID, lastModifiedFolder, lastModifiedDate)
Next i

' En güncel klasör bulunduysa, H sütununa link ekle
If lastModifiedFolder <> "" Then
ws.Cells(cell.Row, "H").Hyperlinks.Add Anchor:=ws.Cells(cell.Row, "H"), _
Address:=lastModifiedFolder, TextToDisplay:="Klasör Linki"
Else
ws.Cells(cell.Row, "H").Value = "Klasör Bulunamadı"
End If
Next cell

MsgBox "Tüm MağazaID'ler için klasörlerde arama tamamlandı.", vbInformation
End Sub

' Alt klasörlerde tarama yapan rekürsif fonksiyon
Sub KlasorleriTara(klasorYolu As String, MagazaID As String, ByRef lastModifiedFolder As String, ByRef lastModifiedDate As Date)
Dim file As String
Dim folderPath As String
Dim folderDate As Date

' İlk olarak mevcut klasörde MağazaID ile başlayan klasörleri kontrol edin
file = Dir(klasorYolu & "\" & "*" & MagazaID & "*", vbDirectory)

Do While file <> ""
If (GetAttr(klasorYolu & "\" & file) And vbDirectory) = vbDirectory Then
folderPath = klasorYolu & "\" & file

' Klasörün gerçekten var olup olmadığını kontrol edin
If Dir(folderPath, vbDirectory) <> "" Then
' Klasörün son değiştirilme tarihini al
folderDate = FileDateTime(folderPath)

' Eğer bu klasör en güncel klasörse bilgileri sakla
If folderDate > lastModifiedDate Then
lastModifiedDate = folderDate
lastModifiedFolder = folderPath
End If
End If
End If

' Sonraki klasöre geç
file = Dir
Loop
End Sub

arkadaşlar yardımcı olacak var mıdır?

"Alt Klasörleri" ve "Alt Klasörlerdeki Tüm Dosyaları" Listeleme

halit3

Uzman

TURKOLOG

Ekli dosyalar

halit3

Uzman

muyat

halit3

Uzman

konas06

halit3

Uzman

halit3

Uzman

Theyakops

halit3

Uzman

aydogankemal

Hoksisamuray1

Enes Kolbaş

Hoksisamuray1

Enes Kolbaş