klasör içeriğine toplu köprü oluşturma

[mustafa038]

herkese merhabalar.
benim şöyle bir isteğim var
bir klasör var a klasörü bunun içerisinde yine 1,2,3,4 .. gibi klasörler mevcut.
bu klasörlerin içerisinde bazılarında direk bazılarında yine alt klasörlerle excel dosyaları mevcut.
bu dosyaları excel de köprü olarak eklemek istiyorum yolu ile beraber olur sa daha iyi olur.
şimdiden teşekkürler.
iyi çalışmalar.

 

[halit3]

Bu kodlar sitede mevcut arama yapmak lazım.

kod bir

Public sat As Long
Sub dosyaListele()

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
Range("A1") = "Dosya Yolu"
Range("B1") = "Dosya Adı"
Range("C1") = "Dosya Tipi"
Range("D1") = "Dosya Boyutu"
Range("E1") = "Oluşturulma Tarihi"
Range("F1") = "Son Erişim Tarihi"
Range("G1") = "Son Düzenleme Tarihi"
Range("H1") = "Son Düzenleme Zamanı"

AltListe (Kaynak)
MsgBox "işlem tamam !", vbInformation, "DİKKAT"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Set Obj = Nothing
Set Klasor = Nothing
Exit Sub
Hata: MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
End Sub

Private Sub AltListe(yol As String)
Dim klsrAra, klsrLst As Object, Dosya
Set klsrLst = CreateObject("Scripting.FileSystemObject")
'dosya = Dir(yol & "\*.*")
'While dosya <> ""
'DoEvents
'On Error Resume Next
'With klsrLst.GetFile(yol & "\" & dosya)

For Each Dosya In klsrLst.GetFolder(yol).Files
With klsrLst.GetFile(Dosya)
If .Type = "Microsoft Excel Çalışma Sayfası" Then
sat = [a65000].End(3).Row + 1
'sat = Rows.Count + 1 ' Columns.Count

If sat >= Rows.Count Then Exit Sub

Cells(sat, 1) = yol
Cells(sat, 2) = Dosya.Name
ActiveSheet.Hyperlinks.Add Anchor:=Range("B" & sat), Address:=Dosya
Range("C" & sat) = .Type
Range("D" & sat) = Format(.Size / 1024, "#,##0.0000") & " Kb"
Range("E" & sat) = Format(.DateCreated, "dd.mm.yyyy")
Range("F" & sat) = Format(.DateLastAccessed, "dd.mm.yyyy")
Range("G" & sat) = Format(.DateLastModified, "dd.mm.yyyy")
Range("H" & sat) = Format(.DateLastModified, "hh:mm:ss")
End If
End With
Next

'dosya = Dir
'Wend

On Error GoTo sonraki
For Each klsrAra In klsrLst.GetFolder(yol).SubFolders
Call AltListe(klsrAra.Path)
sonraki:
Next
End Sub

kod iki

Dim Klasor As Object
Dim Kaynak As String
Dim sat1 As String

Sub dosyalarılistele2()

a = MsgBox("Klasörün içindeki dosyaların sayfalarının adını yazdırmak istiyormusunuz.?", vbYesNo + vbInformation, " uyarı")
If a = vbNo Then
Exit Sub
End If

Cells.ClearContents
Cells.Hyperlinks.Delete
Cells.Font.ColorIndex = 0

Set Klasor = CreateObject("shell.application").browseforfolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.Items.Item.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla

sat1 = 2
Liste (Kaynak)

Application.DisplayAlerts = False

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 Liste(yol As String)
Dim fL As Object, f As Object, Dosya As Object

Set fL = CreateObject("Scripting.FileSystemObject")
Cells(sat1, 1) = yol
For Each Dosya In fL.GetFolder(yol).Files

Uzanti = fL.GetExtensionName(Dosya)

Application.DisplayAlerts = False
If ThisWorkbook.Name <> Dosya.Name And fL.GetFile(Dosya).Type = "Microsoft Excel Çalışma Sayfası" Then

Dim Katalog As Object, Data As Object, Tablo As Object
Dim son1
Set Data = CreateObject("ADODB.Connection")
Set Katalog = CreateObject("ADOX.Catalog")
Dosya_Yolu = (Dosya)
If Uzanti = "xls" Or Uzanti = "xlsb" Or Uzanti = "xlsx" Or Uzanti = "xlsm" Then

sut = 3
On Error Resume Next

If Uzanti = "xls" Then
Data.Open "Driver={Microsoft Excel Driver (*.xls)};Dbq=" & Dosya_Yolu & ";"
Else
Data.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};Dbq=" & Dosya_Yolu & ";"
End If

Cells(sat1, 3) = "Çalışma kitabı korumalı"
Katalog.ActiveConnection = Data
For Each Tablo In Katalog.Tables
If InStr(1, Tablo.Type, "TABLE") > 0 Then
If Right(Tablo.Name, 19) <> "kaynağından_sorgula" Then
If Right(Tablo.Name, 14) <> "Yazdırma_Alanı" Then
son1 = Replace(Tablo.Name, "'", "")
If Right(son1, 1) <> "_" Then
If Right(son1, 1) = "$" Then
If sut = Columns.Count Then
sut = 3
sat1 = sat1 + 1
End If

Cells(sat1, sut).Hyperlinks.Add Anchor:=Cells(sat1, sut), Address:=Dosya, SubAddress:=Left$(son1, Len(son1) - 1) & "!A1", TextToDisplay:=Left$(son1, Len(son1) - 1)

sut = sut + 1
End If
End If
End If
End If
End If
Next
Set Data = Nothing
Set Katalog = Nothing
Cells(sat1, 2).Hyperlinks.Add Anchor:=Cells(sat1, 2), Address:=Dosya, SubAddress:="" & firstAddress, TextToDisplay:=Dosya.Name 'fL.GetBaseName(Dir(Dosya))
If Cells(sat1, 3) = "Çalışma kitabı korumalı" Then
sat1 = sat1 + 1
End If
sat1 = sat1 + 1
End If
End If

Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).SubFolders
Kaynak = f.Path

Liste (Kaynak)
sonraki:
Next

Set fL = Nothing
End Sub

 

[mustafa038]

teşekkürler.
foruma baktım ama bulamadım.
daha önce bulmuştum fakat o kod sadece bir klasör içeriğini göstermekteydi. alt klasörleri ve içeriğindeki excel dosyalarını göstermiyordu.
bu arada 3 kodu da çalıştıramadım
yardım edebilirseniz sevinirim.

 

[alicimri]

Sn. halit3 in kodlarını ve internetten bulduğum kodları biraz harmanladım, "yol" u kendinize göre düzeltin.
https://stackoverflow.com/questions/22645347/loop-through-all-subfolders-using-vba

Sub NonRecursiveMethod()
    Dim fso, oFolder, oSubfolder, oFile, queue As Collection
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set queue = New Collection
    queue.Add fso.GetFolder([COLOR="Red"]"D:\a"[/COLOR]) 
    Do While queue.Count > 0
        Set oFolder = queue(1)
        queue.Remove 1
        For Each oSubfolder In oFolder.SubFolders
            queue.Add oSubfolder 'enqueue
        Next oSubfolder
        For Each oFile In oFolder.Files
        If InStrRev(oFile.Name, "xls") <> 0 Then
        
sat = [a65000].End(3).Row + 1
If sat >= Rows.Count Then Exit Sub
Cells(sat, 2) = oFile.Name
Cells(sat, 1) = oFolder
ActiveSheet.Hyperlinks.Add Anchor:=Range("B" & sat), Address:=oFile
End If
        Next oFile
    Loop
End Sub

 

[mustafa038]

teşekkür ederim istediğim gibi oldu;
yalnız xls yanında .xlsx beraber listeleyebilir miyiz.
tekrardan teşekkür ederim.

 

[alicimri]

Uzantısı ne olursa olsun, bütün Excel dosyalarını listeliyor, deneyin.

 

[D.Ozsahin]

Selamlar Arkadaşlar.
Konu baya eski ama buna bir ekleme yapabilir miyiz ?
Klasör içerisindeki dokümanları Excel sayfasına listeleyip linkledikten sonra, Excel'de linke tıklayınca o dokümanı açmadan farklı kaydet penceresi gelmesi sağlanabilir mi ?
Ya da bu verdiğiniz formülden bağımsız şekilde pdf ler için köprü oluşturulmuş bir excel sayfasında linke tıklayınca pdf dosyasını açmadan o dosyayı farklı bir klasöre kaydetmemi sağlasın.