loop files in subfolder

T

tubrak

Board Regular
Joined
May 30, 2021
Messages
216
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

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
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

S
  • Question
List All SharePoint Files In Folder
Replies
2
Views
53
sspatriots
S
T
  • Solved
List files in folder using named range?
Replies
1
Views
315
KOKOSEK
KOKOSEK
J
  • Question
Merge all pdf files from a folder into single PDF using VBA
2
Replies
10
Views
2K
Dan_W
D
N
  • Solved
Code to open csv file using ws.QueryTables.Add failing
Replies
5
Views
479
Domenic
D
S
  • Solved
Search string in First Page Header of Word docs in Folder (sub folders)
2 3
Replies
24
Views
857
Sleeplol
S

Forum statistics

Threads
1,214,647
Messages
6,120,722
Members
448,987
Latest member
marion_davis

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