Klasör içindeki klasör isimlerinin A sütununa listelenmesi

cebelitarık · 21 Şubat 2008

Klasör içindeki hertürlü klasör ve dosya isimlerinin A sütununa listelenmesi ve değiş

Forumun Değerli üyeleri Hayırlı günler

Forumda bu konuda arama yaptım Fakat örnekler dosya çeşitleri ile ilgili ben ise her türlü klasör ve dosya isimlerini listelemek istiyorum.

Arkadaşlar bir klasör içindeki hertürlü dosyanın isimlerini A sütununa listesini almak istiyorum.

Buna ilave olarak eğer mümkünse A sütununa aldığım dosya isimlerini, karşılığındaki B sütununa yazdığım ve benim belirlediğim yeni isimleri ile değiştirmek istiyorum. Bu şekilde binlerce dosyam var çok ikrama geçecek.

Yardımlarınızı rica ediyorum.
Saygılar

cebelitarık · 21 Şubat 2008

Lütfen konu hakkında bilgisi olan arkadaşlardan ilgi bekliyorum.
Saygılar

Zeki Gürsoy · 21 Şubat 2008

Klasör altında alt klasör bulunuyor mu?

cebelitarık · 21 Şubat 2008

Sayın Anemos
ilgin için teşekkür ederim.
Klasör içinde alt klasör ve yanında resim, word, excell gibi her türlü dosya bulunabiliyor

Leoncio · 21 Şubat 2008

Merhaba;
Klasör veya dizin içindeki dosya isimlerini aşağıdaki kod ile listeleyebilirsin.

Option Explicit
Sub dosyalarilistele()
Dim i As Integer
With Application.FileSearch
.NewSearch
.LookIn = "d:\"
.Filename = "*.xls"
.SearchSubFolders = True
.MatchTextExactly = True
.Execute
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Cells(i, 1) = .FoundFiles(i)
Next i
End If
End With
End Sub

Zeki Gürsoy · 21 Şubat 2008

Alternatif. Office 2007 de FileSearch sorunu yaşayanlar için kullanışlıdır.

Kod:

Sub Start()
Dim klasor As Object
 
Set klasor = CreateObject("Shell.Application").BrowseForFolder _
                    (0, "L&#252;tfen bir klasor se&#231;in !", 1)
                    
Liste (klasor.Items.Item.Path)
AltListe (klasor.Items.Item.Path)
 
Set klasor = Nothing
End Sub
 
Private Sub Liste(yol As String)
Dim dosya As String, i As Long
 
    dosya = Dir(yol & "\*.*")
    i = 1
    While dosya <> ""
        DoEvents
        i = i + 1
        Cells(i, 1) = yol & dosya
        dosya = Dir
    Wend
End Sub
 
Private Sub AltListe(yol As String)
Dim fL As Object, f As Object, dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).SubFolders
 
On Error GoTo sonraki
For Each f In fL
    dosya = Dir(f.Path & "\*.*")
    
    While dosya <> ""
        DoEvents
        j = [a65000].End(3).Row + 1
        Cells(j, 1) = yol & "\" & dosya
        dosya = Dir
    Wend
    
    AltListe (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

cebelitarık · 21 Şubat 2008

Sayın leventer ve Anemos kardeşler çok teşekkür ederim
dosya isimlerini listeledim
Ancak şimdi işi bitirecek kısım şöyle

A sütununda dosya ve klasör isimleri sıralandı
A sütunundadaki her dosyanın B sutunundaki karşılığına orjinal dosya isminden başka dosya isimleri yazdıktan sonra toplu olarak tüm dosya isimlerini yenileri ile farklı yeni bir klasör altında yeniden oluşturmak istiyorum
benim gibi acemilere çok zor fakat
Sizler için kolay olsa gerek
Saygılar

Leoncio · 21 Şubat 2008

Bir sorum olacak yalnız;

Dosya isimleri A sütununda sıraladı B sütunundaki yeni isimler ile değiştirilecek. Yeni isimler sıralımı olacak yani b sütunundaki isimlere örnek verecek olursak örneğin; levent1,levent2,levent3........... şeklindemi gidecek.
ikincisi ise; bu dosya değişiklikleri sadece .xls dosyalarındamı olacak.

cebelitarık · 21 Şubat 2008

bu değişiklikler sadce jpg uzantılı dosyalar için olacak

ve her dosya için bir birini takip eden dizin isimler değilde farklı farklı isimleri b sütununa ayrı ayrı yazacağım
dosyalar içinde bir numaranında yer aldığı resim dosyaları
resimdeki numaraya açıp bakıp o numarayı dosya ismi olarak vereceğim
ayrıca bir görünleme makrom var onunla a sütununda gezerken resimleri sıra ile görüntüleyebiliyorum

cebelitarık · 21 Şubat 2008

Aşağıdaki makro ile resimleri anında görüntüleyebiliyorum.
Private Sub Worksheet_SELECTIONChange(ByVal Target As Range)
On Error Resume Next
ActiveSheet.Pictures.Delete

If Target.Column <> 1 Then Exit Sub
ActiveSheet.Pictures.Insert ("C:\Documents and Settings\kullanıcı\Belgelerim\Resimlerim\2008 TARAMALAR\" & Target & ".jpg") 'Resimlerinizin bulunduğu yolu yazın.
End Sub

cebelitarık · 21 Şubat 2008

Yardımcı olan arkadaşlara teşekkürler
problemin birinci kısmı çözüldü
inşaallah ikinci kısmıda bir el atarsanız çözülecek

mmmkkk2 · 13 Eylül 2008

zeki gürsoy arkadaşım teşekkür ediyorum.

forum yöneticisi arkadaşada sitem ediyorum.
bayadır sitenizden calışmalarımda yararlanıyorum. birde arkadaşa teşekür etmek için üye oldum.
5 dakkam gitti bu hepyaşanan bir sorun bu ceşitli programlama dilleri kullanıyorum. kaynak kod ararken kısaca cevaplıyabileceğim. sorular var nasıl sizler bana yardımcı olduysanız. benimde yardımcı olabileceğim bircok husus var ken bunları birkenara bırakıp yoluma devam ediyorum. 2 satır yazmak için 5-10 dakka üye ol. hiç yoksa cevap yazmak için üyelik şartı aramayın. her yere üye olmak mümkün değil.
saygılarımla

tahsinanarat · 13 Eylül 2008

Sn. Zeki hocam, aynı anda listelenen dosyalara link verdirebilirmiyiz.

hsayar · 13 Eylül 2008

Zeki Gürsoy' Alıntı:

Alternatif. Office 2007 de FileSearch sorunu yaşayanlar için kullanışlıdır.

Kod:

Sub Start()
Dim klasor As Object
 
Set klasor = CreateObject("Shell.Application").BrowseForFolder _
                    (0, "Lütfen bir klasor seçin !", 1)
 
Liste (klasor.Items.Item.Path)
AltListe (klasor.Items.Item.Path)
 
Set klasor = Nothing
End Sub
 
Private Sub Liste(yol As String)
Dim dosya As String, i As Long
 
    dosya = Dir(yol & "\*.*")
    i = 1
    While dosya <> ""
        DoEvents
        i = i + 1
        Cells(i, 1) = yol & dosya
        dosya = Dir
    Wend
End Sub
 
Private Sub AltListe(yol As String)
Dim fL As Object, f As Object, dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).SubFolders
 
On Error GoTo sonraki
For Each f In fL
    dosya = Dir(f.Path & "\*.*")
 
    While dosya <> ""
        DoEvents
        j = [a65000].End(3).Row + 1
        Cells(j, 1) = yol & "\" & dosya
        dosya = Dir
    Wend
 
    AltListe (f.Path)
sonraki:
Next
 
Set fL = Nothing
End Sub

Zeki Hocam Kodlar için teşekkür ederim şöylşe bir düzenleme mümkün mü?
Mesala c:\Belgelerim\Excel\kitap1.xls dosyası mevcut olsun
a sütununa dosyanın adı yani; kitap1.xls
b sütununa dosyanın yolunu yani; c:\Belgelerim\Excel\
kısmını yazacak
Mümkünse
c sütununa dosyanın kaç kb olduğunu
d sütununa dosyanın erişim tarihini falan yazsın.

hsayar · 16 Eylül 2008

14. mesajım güncelliğini koruyor, kolay gelsin

Haluk · 16 Eylül 2008

hsayar' Alıntı:
14. mesajım güncelliğini koruyor, kolay gelsin

Kod:

Sub Test()
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set MyFile = FSO.GetFile("D:\TestFolder\TestEmail.xls")
    Range("A1") = "Dosya Ad&#305;"
    Range("B1") = "Klas&#246;r"
    Range("C1") = "Dosya Tipi"
    Range("D1") = "Dosya Boyutu"
    Range("E1") = "Olu&#351;turulma Tarihi"
    Range("F1") = "Son Eri&#351;im Tarihi"
    Range("G1") = "Son D&#252;zenleme Tarihi"
    Range("H1") = "Son D&#252;zenleme Zaman&#305;"
    Range("A1:H1").Font.Bold = True
    Range("A1:H1").Font.Color = vbRed
    Range("A2") = MyFile.Name
    Range("B2") = MyFile.ParentFolder
    Range("C2") = MyFile.Type
    Range("D2") = MyFile.Size / 1024 & " Kb"
    Range("E2") = Format(MyFile.DateCreated, "dd.mm.yyyy")
    Range("F2") = Format(MyFile.DateLastAccessed, "dd.mm.yyyy")
    Range("G2") = Format(MyFile.DateLastModified, "dd.mm.yyyy")
    Range("H2") = Format(MyFile.DateLastModified, "hh:mm:ss")
    Columns("A:H").AutoFit
End Sub

hsayar · 16 Eylül 2008

Haluk' Alıntı:

Kod:

Sub Test()
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set MyFile = FSO.GetFile("D:\TestFolder\TestEmail.xls")
    Range("A1") = "Dosya Tipi"
    Range("B1") = "Dosya Boyutu"
    Range("C1") = "Oluşturulma Tarihi"
    Range("D1") = "Son Erişim Tarihi"
    Range("E1") = "Son Düzenleme Tarihi"
    Range("F1") = "Son Düzenleme Zamanı"
    Range("A1:F1").Font.Bold = True
    Range("A1:F1").Font.Color = vbRed
    Range("A2") = MyFile.Type
    Range("B2") = MyFile.Size / 1024 & " Kb"
    Range("C2") = Format(MyFile.DateCreated, "dd.mm.yyyy")
    Range("D2") = Format(MyFile.DateLastAccessed, "dd.mm.yyyy")
    Range("E2") = Format(MyFile.DateLastModified, "dd.mm.yyyy")
    Range("F2") = Format(MyFile.DateLastModified, "hh:mm:ss")
    Columns("A:F").AutoFit
End Sub

Haluk hocam öncelikle ilginize teşekkür ederim... Ancak benim istediğim tam olarak zeki hocamnın aşağıdaki kodları çalışırken
Alternatif. Office 2007 de FileSearch sorunu yaşayanlar için kullanışlıdır.

Kod:

Sub Start()
Dim klasor As Object
 
Set klasor = CreateObject("Shell.Application").BrowseForFolder _
                    (0, "Lütfen bir klasor seçin !", 1)
 
Liste (klasor.Items.Item.Path)
AltListe (klasor.Items.Item.Path)
 
Set klasor = Nothing
End Sub
 
Private Sub Liste(yol As String)
Dim dosya As String, i As Long
 
    dosya = Dir(yol & "\*.*")
    i = 1
    While dosya <> ""
        DoEvents
        i = i + 1
        Cells(i, 1) = yol & dosya
        dosya = Dir
    Wend
End Sub
 
Private Sub AltListe(yol As String)
Dim fL As Object, f As Object, dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).SubFolders
 
On Error GoTo sonraki
For Each f In fL
    dosya = Dir(f.Path & "\*.*")
 
    While dosya <> ""
        DoEvents
        j = [a65000].End(3).Row + 1
        Cells(j, 1) = yol & "\" & dosya
        dosya = Dir
    Wend
 
    AltListe (f.Path)
sonraki:
Next
 
Set fL = Nothing
End Sub

ilgili işlemlerin yan sütunlarına yapılmasıdır. yani set etme işlemi döngü içinde yapılacak,
Saygılarımla,

tahsinanarat · 16 Eylül 2008

Sn. hsayar şu şekilde bir kod buldum, dosyalara link de veriyor, incelermisiniz.

Sub Dateiname_Hyperlink()
Dim StDateiname As String
Dim Dateiform As String
Dim InI As Long, TotFiles As Long
Dim Suchpfad As String
Dim OldStatus As Variant
Suchpfad = InputBox("Yolunu değiştirebilirsiniz", "Adres yolu", Application.DefaultFilePath)
If Suchpfad = "" Then Exit Sub
Dateiform = InputBox("Dosya uzantısını siz değiştiriniz", "Uzantı", "*.xls")
If Dateiform = "" Then Exit Sub
Application.ScreenUpdating = True
OldStatus = Application.StatusBar
Sheets.Add After:=Worksheets(Worksheets.Count)
With Application.FileSearch
.LookIn = Suchpfad
.SearchSubFolders = True
.Filename = Dateiform
If .Execute() > 0 Then
TotFiles = .FoundFiles.Count
Application.StatusBar = "Total " & TotFiles & " gefunden"
For InI = 1 To .FoundFiles.Count
Application.StatusBar = "Datei: " & InI & " von " & TotFiles
StDateiname = Mid(.FoundFiles(InI), InStrRev(.FoundFiles(InI), "\") + 1)
ActiveSheet.Hyperlinks.Add Anchor:=Cells(InI, 1), _
Address:=.FoundFiles(InI), TextToDisplay:=StDateiname
Cells(InI, 2) = FileLen(.FoundFiles(InI))
Cells(InI, 3) = FileDateTime(.FoundFiles(InI))
Next InI
End If
End With
Application.StatusBar = OldStatus
Application.ScreenUpdating = True
End Sub

hsayar · 16 Eylül 2008

sn arat alakanıza teşekkür ederim yalnız kullandığım excel versiyonunun 2007 olması nedeni ile işime yaramıyor.

hsayar · 17 Eylül 2008

Değerli Hocalarım sorunum devam ediyor,
Ancak 6. mesajda yer alan kodlarda bir klasör seçin uygulamsında masaüsütü seçildiğinde hata almadan işleme devam edebilmenin yöntemini buldum müsadenizle pyalşmak istiyorum,

Kod:

Sub Start()
Dim klasor As Object, klsrMsUstu$
 
Set klasor = CreateObject("Shell.Application").BrowseForFolder(0, "L&#252;tfen bir klasor se&#231;in !", 1)
klsrMsUstu = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    If klasor = "Masa&#252;st&#252;" Or klasor = "Desktop" Then
        Liste (klsrMsUstu)
        AltListe (klsrMsUstu)
    ElseIf klasor <> "Masa&#252;st&#252;" Then
        Liste (klasor.Items.Item.Path)
        AltListe (klasor.Items.Item.Path)
    Else
        Exit Sub
    End If
Set klasor = Nothing
End Sub

Start prosodürünü değiştirmeniz yeterlidir.

Klasör içindeki klasör isimlerinin A sütununa listelenmesi

cebelitarık

cebelitarık

Zeki Gürsoy

Uzman

cebelitarık

Leoncio

Zeki Gürsoy

Uzman

cebelitarık

Leoncio

cebelitarık

cebelitarık

cebelitarık

mmmkkk2

tahsinanarat

hsayar

hsayar

Haluk

Özel Üye

hsayar

tahsinanarat

hsayar

hsayar