Makro kodları ile klasör ve dosya ayrımı yapma

selimm · 29 Eylül 2011

Merhaba arkadaşlar,

Ekteki deneme klasörü, alt klasörleri ve alt klasörler de excel dosyaları içermektedir. Makro kodları ile ekteki "Dosya Yolu Seçme" excel dosyasında olduğu gibi, dosya yollarını excel sayfasına yazırlabiliyorum.

Dosya yolu seçme butununa tıkladığımda,
her klasör için bir sayfa oluşturup, bu sayfalarda ilgili klasörün içindeki dosyaların dosya yollarını yazdırtmak istiyorum. Yani klasör ile dosyayı makro ile ayırt ettiremedim.

Bu tür bir ayrım yapılabilir mi?

Şimdiden teşekkürler.

mancubus · 29 Eylül 2011

Kod:

Sub klasör_dosya()

Dim wks As Worksheet
Dim fYol As String, fAd As String

fYol = "C:\DOSYALAR\"
fAd = Dir(fYol, vbDirectory)
Do While fAd <> ""
    If fAd <> "." And fAd <> ".." Then
        If (GetAttr(fYol & fAd) And vbDirectory) = vbDirectory Then
            Set wks = Worksheets.Add(After:=Worksheets(Worksheet.Count))
            wks.Name = fAd
            wks.Activate
[COLOR="SeaGreen"]            'tek bir klasördeki dosyaları listeleyen kodlar buraya
            'kodlar
            'kodlar[/COLOR]            
        End If
    End If
    fAd = Dir
Loop

End Sub

mancubus · 30 Eylül 2011

bir dosyam vardı, kullandığım. onu revize edince oldu.
sadece fYol = "C:\Users\ben\Documents\" altındaki alt klasörlerin içindeki dosyaları listeler. bu kalsörlerin içinde de alt klasör varsa onları dikkate almaz.

Kod:

Sub klasör_dosya()

Dim fso As Object, fKlasör As Object, fDosya As Object
Dim ws As Worksheet
Dim fYol As String, fAd As String

Set fso = CreateObject("Scripting.FileSystemObject")
fYol = "C:\Users\ben\Documents\"
fAd = Dir(fYol, vbDirectory)

Do While fAd <> ""
    If fAd <> "." And fAd <> ".." Then
        If (GetAttr(fYol & fAd) And vbDirectory) = vbDirectory Then
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = fAd
            Set ws = ActiveSheet
            ws.Cells(1, 1).Value = "Klasördeki Dosyalar"
            Set fKlasör = fso.GetFolder(fYol & fAd)
            For Each fDosya In fKlasör.Files
                ws.Cells(ws.UsedRange.Rows.Count + 1, 1).Value = fDosya.Name
            Next
        End If
    End If
    fAd = Dir
Loop

End Sub

selimm · 30 Eylül 2011

Merhaba Mancubus,

Cevabınız için teşekkür ederim.
Benim yukarıda anlatmaya çalıştığım,
Deneme Klasörünün içindeki Alt klasörlerin herbiri için (Örneğin Alt klsör ismi "Raporlar") , bu alt klasörün ismi ile aynı bir excel sayfası oluşturtmak (Örneğin Excel Sayfasının ismi "Raporlar") ve bu alt klasörün içindeki dosya isimlerini (Örneğin "Rapoar1. xls") bu sayfaya yazdırtmak istiyorum.

mancubus · 30 Eylül 2011

eklediğim kod denendi mi?
tam da bunu yapıyor.

Kod:

fYol = "C:\Users\ben\Documents\

buradaki klasörü iyi tanımlamak lazım. alt klasörler neyin altında ise o klasörün adı yazılmalı. ben bunu örnek olarak yazdım.

eğer zipli dosyadaki yapıda ise klasör ve dosyalar, şu olabilir:

Kod:

fYol = ThisWorkbook.Path
If Right(fYol, 1) <> "\" Then fYol = fYol & "\"

Kod:

Sub klasör_dosya()

Dim fso As Object, fKlasör As Object, fDosya As Object
Dim ws As Worksheet
Dim fYol As String, fAd As String

Set fso = CreateObject("Scripting.FileSystemObject")

fYol = ThisWorkbook.Path
If Right(fYol, 1) <> "\" Then fYol = fYol & "\"

fAd = Dir(fYol, vbDirectory)

Do While fAd <> ""
    If fAd <> "." And fAd <> ".." Then
        If (GetAttr(fYol & fAd) And vbDirectory) = vbDirectory Then
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = fAd
            Set ws = ActiveSheet
            ws.Cells(1, 1).Value = "Klasördeki Dosyalar"
            Set fKlasör = fso.GetFolder(fYol & fAd)
            For Each fDosya In fKlasör.Files
                ws.Cells(ws.UsedRange.Rows.Count + 1, 1).Value = fDosya.Name
            Next
        End If
    End If
    fAd = Dir
Loop

End Sub

ben bu kodu çalıştırdığımda 3 tane sayfa ekledi.
kırmızılar oluşan sayfa isimleri, maviler bu sayfaların A1:A3 hücrelerindeki değerler.

Raporlar
Klasördeki Dosyalar
Rapor 1.xls
Rapor 2.xls

Süreçler
Klasördeki Dosyalar
Süreç 1.xls
Süreç 2.xls

Talimatlar
Klasördeki Dosyalar
Talimat 1.xls
Talimat 2.xls

selimm · 30 Eylül 2011

Çok teşşekür ederim Mancubus,

Ben sizin kodunuzda dosya yolunu doğru tanımlayamadığım için kodları çalıştıramadım.
Elinize sağlık.

halit3 · 30 Eylül 2011

Alternatif kod

Kod:

Sub Dosya_Yolu()
Dim Klasor As Object
Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
If Not Klasor Is Nothing Then
If InStr(1, Klasor, "{") > 0 Then GoTo Atla
Liste (Klasor.SELF.Path)
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Set Klasor = Nothing
End Sub
Private Sub Liste(Kalasor As String)
Dim SayfaAdi As String
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(Kalasor).SubFolders
For Each f In fL
SayfaAdi = f.Name
yer = f.Path
On Error Resume Next
If Worksheets(SayfaAdi).Name = True Then
Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = SayfaAdi
Sheets(SayfaAdi).Select
Else
Sheets(SayfaAdi).Select
End If
Range("A2:B65536").Clear
[A1] = "Dosya Yolu ve Dosya Adı"
[B1] = "Dosyayı Son Değiştirme"
i = Worksheets(SayfaAdi).Cells(Rows.Count, "A").End(3).Row + 1
Dim wb As Workbook
Dosya = Dir(yer & "\*.xls")
Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
Application.DisplayAlerts = False
Cells(i, 1) = Kalasor & "\" & SayfaAdi & "\" & Dosya
Cells(i, 1).Hyperlinks.Add Anchor:=Cells(i, 1), Address:=Kalasor & "\" & SayfaAdi & "\" & Dosya, TextToDisplay:=""  'Dosya yolu ve adına köprü atamak
Cells(i, 2) = f.datelastModified
i = i + 1
End If
Dosya = Dir
Wend
Columns("A:B").Select
Columns("A:B").EntireColumn.AutoFit
Range("A1").Select
Next

On Error GoTo sonraki
For Each f In fL
Kalasor = f.Path
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
Application.ScreenUpdating = True
End Sub

subutayı · 30 Aralık 2018

halit3' Alıntı:

Alternatif kod

Kod:

Sub Dosya_Yolu()
Dim Klasor As Object
Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
If Not Klasor Is Nothing Then
If InStr(1, Klasor, "{") > 0 Then GoTo Atla
Liste (Klasor.SELF.Path)
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Set Klasor = Nothing
End Sub
Private Sub Liste(Kalasor As String)
Dim SayfaAdi As String
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(Kalasor).SubFolders
For Each f In fL
SayfaAdi = f.Name
yer = f.Path
On Error Resume Next
If Worksheets(SayfaAdi).Name = True Then
Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = SayfaAdi
Sheets(SayfaAdi).Select
Else
Sheets(SayfaAdi).Select
End If
Range("A2:B65536").Clear
[A1] = "Dosya Yolu ve Dosya Adı"
[B1] = "Dosyayı Son Değiştirme"
i = Worksheets(SayfaAdi).Cells(Rows.Count, "A").End(3).Row + 1
Dim wb As Workbook
Dosya = Dir(yer & "\*.xls")
Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
Application.DisplayAlerts = False
Cells(i, 1) = Kalasor & "\" & SayfaAdi & "\" & Dosya
Cells(i, 1).Hyperlinks.Add Anchor:=Cells(i, 1), Address:=Kalasor & "\" & SayfaAdi & "\" & Dosya, TextToDisplay:=""  'Dosya yolu ve adına köprü atamak
Cells(i, 2) = f.datelastModified
i = i + 1
End If
Dosya = Dir
Wend
Columns("A:B").Select
Columns("A:B").EntireColumn.AutoFit
Range("A1").Select
Next

On Error GoTo sonraki
For Each f In fL
Kalasor = f.Path
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
Application.ScreenUpdating = True
End Sub

subutayı · 30 Aralık 2018

merhaba halit3 bey,
7. mesajdaki kodunuzu kullandım ama benim isteğime cevap vermedi. kodu bana göre uyarlama şansınız var mı? kodunuz klasör içindeki alt klasörlerin isimlerini excel çalışma kitabında sayfa isimleri açarak oluşturuyor ve dosya isimlerini sayfalara yolları ile birlikte yazıyor.
bana şu şekilde lazım.
A sütünuna sadece alt klasördeki dosya isimlerini yazsın. B sütüna da alt klasör isimlerini yazsın. bu şekilde değiştirebilir misiniz. ? teşekürler.

subutayı · 30 Aralık 2018

macroyu halit3 yazmış ama formdaki diğer arkadaşlar da yardımcı olabilirse sevinirim.

Makro kodları ile klasör ve dosya ayrımı yapma

selimm

Ekli dosyalar

mancubus

Destek Ekibi

mancubus

Destek Ekibi

selimm

mancubus

Destek Ekibi

selimm

halit3

Uzman

subutayı

subutayı

subutayı