loop files in subfolder

T

tubrak

Board Regular
Joined
May 30, 2021
Messages
218
Office Version
  1. 2019
Platform
  1. Windows
I try making this code also loop in subfolders but I failed
this code just loop in folder
VBA Code: 
Sub ListAllFilesInFolderCreateHyperlink()
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Long

Set oFSO = CreateObject("Scripting.Filesystemobject")
Set oFolder = oFSO.GetFolder("C:\Users\lap\Desktop\ss\")

i = 1

For Each oFile In oFolder.Files
Cells(i + 1, 2) = oFile.Name
Cells(i + 1, 3) = oFile.Path
Range(Cells(i + 1, 1), Cells(i + 1, 1)).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=oFile.Path, TextToDisplay:=oFile.Name

i = i + 1

Next oFile

End Sub
how can i mod this code ,please
 

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
Sort by date Sort by votes
Give this a go
It will first process all the files in the main folder then process all the files in each subfolder in the main folder

VBA Code: 
Sub ListAllFilesInFolderCreateHyperlink()
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim SubFolder As Object
Dim i As Long

Set oFSO = CreateObject("Scripting.Filesystemobject")
Set oFolder = oFSO.GetFolder("C:\Users\lap\Desktop\ss\")

i = 1
'Get files in main folder
For Each oFile In oFolder.Files
    Cells(i + 1, 2) = oFile.Name
    Cells(i + 1, 3) = oFile.Path
    Range(Cells(i + 1, 1), Cells(i + 1, 1)).Select
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=oFile.Path, TextToDisplay:=oFile.Name
    
    i = i + 1

Next oFile

'Get files in subfolders
For Each SubFolder In oFolder.SubFolders
    i = 1
    'Get files in main folder
    For Each oFile In oFolder.Files
        Cells(i + 1, 2) = oFile.Name
        Cells(i + 1, 3) = oFile.Path
        Range(Cells(i + 1, 1), Cells(i + 1, 1)).Select
        ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=oFile.Path, TextToDisplay:=oFile.Name
        
        i = i + 1
    
    Next oFile
Next SubFolder
End Sub
 
Upvote 0
thanks but it doesn't success . still loop in just folder
 
Upvote 0
how about this
VBA Code: 
Public oldNR As Long
Sub HyperlinkDirectory()
''''''''''''''''''''''''''''''''''''''''''Need reference -Microsoft Visual Basic for Applications Extensibility 5.3''''''''''''''''''''''''''''''''''''

Dim fPath As String
Dim fType As String
Dim fname As String
Dim filePath As String
Dim NR As Long
Dim AddLinks As Boolean

      For Each Sheet In ActiveWorkbook.Worksheets
        If Sheet.Name = "ALL FILES LIST" Then
            Sheets("ALL FILES LIST").Cells.Delete
            F = True
            Exit For
        Else
            F = False
        End If
    Next

    If Not F Then Sheets.Add.Name = "ALL FILES LIST"
    Sheets("ALL FILES LIST").Select
    

'''''''''''''''Select folder
    With Application.FileDialog(msoFileDialogFolderPicker)
       .Show
        If .SelectedItems.Count > 0 Then
            fPath = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With
 Range("B1").Value = fPath
'''''''''''''''''Types of files
     fType = "*"

  If fType = "False" Then Exit Sub
'
''''''''''''''''''Option to create hyperlinks
    AddLinks = vbYes

'''''''''''''''''Create report
    Application.ScreenUpdating = False
    NR = 4
    With ActiveSheet
        .Range("A:C").Clear
        .[A2] = "LIST OF FILES"
        
            Call FindFilesAndAddLinks(fPath, fType, NR, AddLinks)
Range("B1").Value = fPath
        End With
        With ActiveSheet
          .Range("A:B").Columns.AutoFit
          .Range("B:B").HorizontalAlignment = xlCenter



        With ActiveSheet
        Range("A2").Select
        Selection.Font.Bold = True
 
    End With
        Columns("A:A").Select
        Selection.Font.Underline = xlUnderlineStyleNone
    End With

    Application.ScreenUpdating = True

End Sub

Private Sub FindFilesAndAddLinks(fPath As String, fType As String, ByRef NR As Long, AddLinks As Boolean)
Dim fname As String
Dim oFS As New FileSystemObject
Dim oDir
Dim fnamePath As String

'Files under current dir
On Error Resume Next
fname = Dir(fPath & "*." & fType)
With ActiveSheet

    'Write folder name
    .Range("A" & NR) = fPath
    .Range("A" & NR).Select
    If AddLinks Then .Hyperlinks.Add Anchor:=Selection, _
           Address:=fPath, _
            TextToDisplay:="FOLDER NAME:  " & "  " & UCase(Split(fPath, "\")(UBound(Split(fPath, "\")) - 1))
                   Selection.Font.Bold = True
             Selection.Font.Size = 10
             Selection.Font.Name = "Arial"
             Selection.Font.Underline = xlUnderlineStyleNone
             With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = 0.399975585192419
        .PatternTintAndShade = 0
    End With

    With Selection.Font
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
    End With

    NR = NR + 1

    Do While Len(fname) > 0

      'filename
        If .Range("A" & NR) <> "" Then Debug.Print "Overwriting " & NR
        .Range("A" & NR) = fname
              'modified
        .Range("B" & NR) = fname
        .Range("C" & NR) = fnamePath
      'hyperlink
        .Range("A" & NR).Select
        If AddLinks Then .Hyperlinks.Add Anchor:=Selection, _
            Address:=fPath & fname, _
            TextToDisplay:=fname

      'set for next entry
        NR = NR + 1
        fname = Dir
    Loop

    'Files under sub dir
    Set oDir = oFS.GetFolder(fPath)
    For Each oSub In oDir.subfolders

        NR = NR + 1

        Call FindFilesAndAddLinks(oSub.Path & "\", fType, NR, AddLinks)
    
    Next oSub
    
End With

    

End Sub
 
Upvote 0
my mistake
use code below- note you will need reference -Microsoft Scripting Runtime
VBA Code: 
Public oldNR As Long
Sub HyperlinkDirectory()
''''''''''''''''''''''''''''''''''''''''''Need reference -Microsoft Scripting Runtime''''''''''''''''''''''''''''''''''''

Dim fPath As String
Dim fType As String
Dim fname As String
Dim NR As Long
Dim AddLinks As Boolean

      For Each Sheet In ActiveWorkbook.Worksheets
        If Sheet.Name = "ALL FILES LIST" Then
            Sheets("ALL FILES LIST").Cells.Delete
            F = True
            Exit For
        Else
            F = False
        End If
    Next

    If Not F Then Sheets.Add.Name = "ALL FILES LIST"
    Sheets("ALL FILES LIST").Select
    

'''''''''''''''Select folder
    With Application.FileDialog(msoFileDialogFolderPicker)
       .Show
        If .SelectedItems.Count > 0 Then
            fPath = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With
 Range("B1").Value = fPath
'''''''''''''''''Types of files
     fType = "*"

  If fType = "False" Then Exit Sub
'
''''''''''''''''''Option to create hyperlinks
    AddLinks = vbYes

'''''''''''''''''Create report
    Application.ScreenUpdating = False
    NR = 4
    With ActiveSheet
        .Range("A:C").Clear
        .[A2] = "LIST OF FILES"
        
            Call FindFilesAndAddLinks(fPath, fType, NR, AddLinks)
Range("B1").Value = fPath
        End With
        With ActiveSheet
          .Range("A:C").Columns.AutoFit
          


        With ActiveSheet
        Range("A2").Select
        Selection.Font.Bold = True
 
    End With
        Columns("A:A").Select
        Selection.Font.Underline = xlUnderlineStyleNone
    End With

    Application.ScreenUpdating = True

End Sub

Private Sub FindFilesAndAddLinks(fPath As String, fType As String, ByRef NR As Long, AddLinks As Boolean)
Dim fname As String
Dim oFS As New FileSystemObject
Dim oDir


'Files under current dir
On Error Resume Next
fname = Dir(fPath & "*." & fType)
With ActiveSheet

    'Write folder name
    .Range("A" & NR) = fPath
    .Range("A" & NR).Select
    If AddLinks Then .Hyperlinks.Add Anchor:=Selection, _
           Address:=fPath, _
            TextToDisplay:="FOLDER NAME:  " & "  " & UCase(Split(fPath, "\")(UBound(Split(fPath, "\")) - 1))
                   Selection.Font.Bold = True
             Selection.Font.Size = 10
             Selection.Font.Name = "Arial"
             Selection.Font.Underline = xlUnderlineStyleNone
             With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = 0.399975585192419
        .PatternTintAndShade = 0
    End With

    With Selection.Font
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
    End With

    NR = NR + 1

    Do While Len(fname) > 0

      'filename
        If .Range("A" & NR) <> "" Then Debug.Print "Overwriting " & NR
        .Range("A" & NR) = fname
              'modified
        .Range("B" & NR) = fname
        .Range("C" & NR) = fPath & fname
      'hyperlink
        .Range("A" & NR).Select
        If AddLinks Then .Hyperlinks.Add Anchor:=Selection, _
            Address:=fPath & fname, _
            TextToDisplay:=fname

      'set for next entry
        NR = NR + 1
        fname = Dir
    Loop

    'Files under sub dir
    Set oDir = oFS.GetFolder(fPath)
    For Each oSub In oDir.subfolders

        NR = NR + 1

        Call FindFilesAndAddLinks(oSub.Path & "\", fType, NR, AddLinks)
    
    Next oSub
    
End With

    

End Sub
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

A
  • Question Question
Macro-inserted pictures are not showing on other computers
Replies
7
Views
316
rlv01
R
S
  • Question Question
List All SharePoint Files In Folder
Replies
2
Views
392
sspatriots
S
T
  • Solved
List files in folder using named range?
Replies
1
Views
458
KOKOSEK
KOKOSEK
J
  • Question Question
Merge all pdf files from a folder into single PDF using VBA
2
Replies
10
Views
3K
Dan_W
D
F
  • Question Question
How to open and print pdf file in a folder?
Replies
2
Views
193
Jaafar Tribak
Jaafar Tribak

Forum statistics

Threads
1,224,813
Messages
6,181,107
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top