Hucrelere, klasordeki word belgelerini köprülemek

[Yarkan]

Kolay gelsin arkadaşlar. Şöyle bir sıkıntım var;
Bir çok klasor ve içlerinde word belgeler var.
Bir excell sayfasındaki hücrelere bunları tek tek köprülemem gerekiyor.
Ama 1000 li sayılar olduğu için bunun formüllü bir yolu varmıdır???

NOT Basit örnek ektedir...

 

[Yarkan]

Pardon ek yapamadım ama anlayan ve yardımcı olabilecek varsa açıklama yaparım. Sanırım bilene basit istediğim ama ben çözemiyorum.

 

[excelokyanus500]

Deneyin..

Sub docxbul()

    Dim oFSO As Object
    Dim oFolder As Object
    Dim oFile As Object, sf
    Dim i As Integer, colFolders As New Collection, ws As Worksheet
   
    Set ws = ActiveSheet
    ws.Cells.Select
    Selection.Delete Shift:=xlUp
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.getfolder(UseFolderDialogOpen)
   
    colFolders.Add oFolder          'başlanan folder
   
    Do While colFolders.Count > 0
        Set oFolder = colFolders(1)
        colFolders.Remove 1            'bitirilen folder
   
        For Each oFile In oFolder.Files
           ' If oFile.DateLastModified > Now - 7 Then
             If oFSO.GetExtensionName(oFile) = "docx" Then
                ws.Cells(i + 1, 1) = oFolder.Path
                ws.Cells(i + 1, 2) = oFile.Name
                ws.Cells(i + 1, 3) = oFolder.Path & "\" & oFile.Name
                ActiveSheet.Hyperlinks.Add ws.Cells(i + 1, 3), ws.Cells(i + 1, 3).Value 'hyperlinke çevir
                ws.Cells(i + 1, 4) = oFile.DateLastModified
                i = i + 1
            End If
        Next oFile

        'Alt klasörler
        For Each sf In oFolder.subfolders
            colFolders.Add sf
        Next sf
    Loop
   
    Range("A1").Select
   
    ActiveWindow.Zoom = 85

    Cells.EntireColumn.AutoFit
     
End Sub

Public Function UseFolderDialogOpen() As String
    Dim lngCount As Long

    ' Open the folder dialog
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Show

        ' Set Current Folder Path
        For lngCount = 1 To .SelectedItems.Count
            UseFolderDialogOpen = .SelectedItems(lngCount)
        Next lngCount
        
    End With

End Function

 

[Tevfik_Kursun]

Merhaba Arkadaşım,
Fonksiyon çözümlü alternatif te benden olsun.
Klasörlerinizdeki dosyaların isimlerini Excel dosyanızın A sütununa sıralayıp ve B sütunundaki hücrelere de
=KÖPRÜ(DosyaAdı;Dosyayı hatırlatablecek ad) yazaranız, word dosyalarınıza KÖPRÜ oluşturmuş olursunuz.
( =KÖPRÜ(DosyaAdı;DosyaAdı) şeklinde yaparsanız, dosyanızın adı da görünmüş olur )
İyi çalışmalar

 

[Yarkan]

Yardımcı olmaya çalışanlara teşekkürler...
Belirttiklerinizi uygulamaya çalışacağım ama tam istediğim şöyle;
Excell de 1. foto daki gibi listem var.
2. foto gibi de klasörüm var. Ekseldeki karşılıklarına köprü yapmalıyım ve bir sayı ya tıklayınca solundaki yılın, yine solundaki ayın içindeki o gün numaralı word belgesi açılacak. Bunlar binlerce köprü gerektiriyor. bende bu köprüleri formül ya da makro yapabilirmi bunu öğrenmek istemiştim.

Ads-z hosted at ImgBB

Image Ads-z hosted in ImgBB

ibb.co

Ads-z2 hosted at ImgBB

Image Ads-z2 hosted in ImgBB

ibb.co

 

[asdsxx]

Yardımcı olmaya çalışanlara teşekkürler...
Belirttiklerinizi uygulamaya çalışacağım ama tam istediğim şöyle;
Excell de 1. foto daki gibi listem var.
2. foto gibi de klasörüm var. Ekseldeki karşılıklarına köprü yapmalıyım ve bir sayı ya tıklayınca solundaki yılın, yine solundaki ayın içindeki o gün numaralı word belgesi açılacak. Bunlar binlerce köprü gerektiriyor. bende bu köprüleri formül ya da makro yapabilirmi bunu öğrenmek istemiştim.

Ads-z hosted at ImgBB

Image Ads-z hosted in ImgBB

ibb.co

Ads-z2 hosted at ImgBB

Image Ads-z2 hosted in ImgBB

ibb.co

Aşağıdaki dosya işini görebilir sanırım. Daha önce bu forumda paylaşılmıştı
Dosya linki :

İndir Dosyaları Listele

Dosyayı indir Dosyaları Listele

dosya.co

 

[excelokyanus500]

Programda klasör seçme seçeneği ekledim. Belki biraz daha fonksiyonel olmuş olabilir. Deneyin.

Sub docxbul()

    Dim oFSO As Object
    Dim oFolder As Object
    Dim oFile As Object, sf
    Dim i As Integer, colFolders As New Collection, ws As Worksheet
  
    Set ws = ActiveSheet
    ws.Cells.Select
    Selection.Delete Shift:=xlUp
    Set oFSO = CreateObject("Scripting.FileSystemObject")
  
   Set objShell = CreateObject("Shell.Application")
   Set objFolder = objShell.BrowseForFolder(0, "İşlem yapılacak klasörü seçin ", 1, "c:\Programs")
   If objFolder Is Nothing Then
    Exit Sub
   End If

   yol = objFolder.self.Path

    Set oFolder = oFSO.GetFolder(yol)
     ActiveSheet.Cells(1).Resize(1, 4).Value = Array("KLASÖR YOLU", "KLASÖR ADI", "DOSYANIN ADI", "DOSYA YOLU")
    colFolders.Add oFolder          'başlanan folder
  
    Do While colFolders.Count > 0
        Set oFolder = colFolders(1)
        colFolders.Remove 1            'bitirilen folder
  
        For Each oFile In oFolder.Files
           ' If oFile.DateLastModified > Now - 7 Then
             If oFSO.GetExtensionName(oFile) = "docx" Then
                ws.Cells(i + 2, 1) = oFolder.Path
                ActiveSheet.Hyperlinks.Add ws.Cells(i + 1, 1), ws.Cells(i + 1, 1).Value 'hyperlinke çevir
                ws.Cells(i + 2, 2) = GetFileFolderFromPath(oFolder.Path)
                ws.Cells(i + 2, 3) = oFile.Name
                ws.Cells(i + 2, 4) = oFolder.Path & "\" & oFile.Name
                ActiveSheet.Hyperlinks.Add ws.Cells(i + 1, 4), ws.Cells(i + 1, 4).Value 'hyperlinke çevir
                
                i = i + 1
            End If
        Next oFile

        'Alt klasörler
        For Each sf In oFolder.subfolders
            colFolders.Add sf
        Next sf
    Loop
    
    'Görselleştirme
    Columns("A:D").AutoFilter
    Columns("A:A").ColumnWidth = 72.57
    Columns("B:B").ColumnWidth = 26
    Columns("C:C").ColumnWidth = 49.43
    ActiveWindow.Zoom = 85
    Range("A1").Select
    'Cells.EntireColumn.AutoFit
    
End Sub


Public Function GetFileFolderFromPath(ByVal strPath As String) As String
    If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then _
    GetFileFolderFromPath = GetFileFolderFromPath(Left$(strPath, Len(strPath) - 1)) + _
    Right$(strPath, 1)
End Function

 

[Yarkan]

Aşağıdaki dosya işini görebilir sanırım. Daha önce bu forumda paylaşılmıştı
Dosya linki :

İndir Dosyaları Listele

Dosyayı indir Dosyaları Listele

dosya.co

Sağolasınız süper, işime yarar bu

 

[Yarkan]

Çok güzel oldu ama bir sorunum oluştu. Son verilen makroda "doyaları sırala" butonuna basınca bana lazım olan işlemi yaptı. Ancak sıralamayı harf sırasına göre yaptığı ve bana aylar sıralı gerektiği için sorun yaşıyorum. Şimdi foto da görülen sıralamayı aylar (Ocak, Şubat, Mart,...) olacak şekilde en kısa nasıl düzeltirim. Tabii ki sağdaki günlerde ay ile birlikte yeni sırasına gidecekler.

İndir Adsız

Dosyayı indir Adsız

dosya.co

 

[Yarkan]

Tamam çözdüm sağolun. Klasörleri yeniden oluşturup aylara 1, 2, 3,... gibi başlarına numara verdim. sağolun