Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 09-24-2020, 06:46 AM
leeqiang leeqiang is offline How to modify the code to meet the corresponding requirements Windows 10 How to modify the code to meet the corresponding requirements Office 2019
Advanced Beginner
How to modify the code to meet the corresponding requirements
 
Join Date: Aug 2020
Posts: 53
leeqiang is on a distinguished road
Default How to modify the code to meet the corresponding requirements

The code traverses all the files in the folder and its subfolders and extracts the relevant information of the files. I want to make modifications based on the generated results. Column B is the file name of the extracted file. How to base the file name Add a hyperlink to the path where the file is located, so that you can open the corresponding file by directly clicking on a file name. Thank you!



Thank you very much for your help, your code solved my problem.
If you don’t mind, can you help me solve a few further problems? Modified on the basis of this code to achieve the following 4 purposes:



The first one: The data in column D generated by the code is named path, but all the addresses in this column know the folder, and now I want to modify the path of each file to the full path name, that is, there is a file after the original path file name. That is to say, this path is a hyperlink and you can click to open the file directly, but the data in column D shows the complete path.



The second one: add an E column named the creation date of the file. After traversing each file, the creation date of each corresponding file is generated in this column.



Third: Add a column F named file modification date. After traversing each file, the last modification date of each corresponding file is generated in this column.



Fourth: Add a G column named file size, and generate the file size of each corresponding file in this column after traversing each file.

Thanks again, hope to help me!












  1. Dim jg(), k&, tms#
  2. Sub ListFilesFso()
  3. sb& = InputBox("Search Type: AllFiles=0/Files=1/Folder=-1/All Folder=-2", "Find Files", 0)
  4. SpFile$ = InputBox("typeoffiles", "Find Files", ".xl")
  5. If SpFile Like ".*" Then SpFile = LCase(SpFile) & "*"
  6. With Application.FileDialog(msoFileDialogFolderPicker)
  7. If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
  8. End With
  9. If Right(myPath, 1) <> "" Then myPath = myPath & ""
  10. ReDim jg(65535, 3)
  11. jg(0, 0) = "Ext": jg(0, 1) = IIf(sb < 0, IIf(Len(SpFile), "Filename", "No"), "Filename")
  12. jg(0, 2) = "Folder": jg(0, 3) = "Path"
  13. tms = Timer: k = 0: Call ListAllFso(myPath, sb, SpFile)
  14. If sb < 0 And Len(SpFile) = 0 Then Application.StatusBar = "Get " & k & " Folders."
  15. [a1].CurrentRegion = "": [a1].Resize(k + 1, 4) = jg: [a1].CurrentRegion.AutoFilter Field:=1
  16. End Sub
  17. Function ListAllFso(myPath$, Optional sb& = 0, Optional SpFile$ = "")
  18. Set fld = CreateObject("Scripting.FileSystemObject").GetFold er(myPath)
  19. On Error Resume Next
  20. If sb >= 0 Or Len(SpFile) Then
  21. For Each f In fld.Files
  22. t = False
  23. n = InStrRev(f.Name, "."): fnm = Left(f.Name, n - 1): x = LCase(Mid(f.Name, n))
  24. If Err.Number Then Err.Clear
  25. If SpFile = " " Then
  26. t = True
  27. ElseIf SpFile Like ".*" Then
  28. If x Like SpFile Then t = True
  29. Else
  30. If InStr(fnm, SpFile) Then t = True
  31. End If
  32. If t Then k = k + 1: jg(k, 0) = x: jg(k, 1) = "'" & fnm: jg(k, 2) = fld.Name: jg(k, 3) = fld.Path
  33. Next
  34. Application.StatusBar = Format(Timer - tms, "0.0s") & " Get " & k & " Files , Searching in Folder ... " & fld.Path
  35. End If
  36. For Each fd In fld.SubFolders
  37. If sb < 0 And Len(SpFile) = 0 Then k = k + 1: jg(k, 0) = "fld": jg(k, 1) = k: jg(k, 2) = fd.Name: jg(k, 3) = fld.Path
  38. If sb Mod 2 = 0 Then Call ListAllFso(fd.Path, sb, SpFile)
  39. Next
  40. End Function

Last edited by leeqiang; 09-24-2020 at 05:07 PM.
Reply With Quote
  #2  
Old 09-24-2020, 11:17 AM
NoSparks NoSparks is offline How to modify the code to meet the corresponding requirements Windows 10 How to modify the code to meet the corresponding requirements Office 2010
Excel Hobbyist
 
Join Date: Nov 2013
Location: British Columbia, Canada
Posts: 831
NoSparks is just really niceNoSparks is just really niceNoSparks is just really niceNoSparks is just really niceNoSparks is just really nice
Default

put before end sub
Code:
    With ActiveSheet
    For Each cel In .Range("B2", .Range("B" & .Rows.Count).End(xlUp))
        .Hyperlinks.Add Anchor:=.Cells(cel.Row, cel.Column), Address:=cel.Offset(, 2) & "/" & cel & cel.Offset(, -1)
    Next cel
    End With
Reply With Quote
  #3  
Old 09-24-2020, 04:51 PM
leeqiang leeqiang is offline How to modify the code to meet the corresponding requirements Windows 10 How to modify the code to meet the corresponding requirements Office 2019
Advanced Beginner
How to modify the code to meet the corresponding requirements
 
Join Date: Aug 2020
Posts: 53
leeqiang is on a distinguished road
Default

Quote:
Originally Posted by NoSparks View Post
put before end sub
Code:
    With ActiveSheet
    For Each cel In .Range("B2", .Range("B" & .Rows.Count).End(xlUp))
        .Hyperlinks.Add Anchor:=.Cells(cel.Row, cel.Column), Address:=cel.Offset(, 2) & "/" & cel & cel.Offset(, -1)
    Next cel
    End With

Thank you very much for your help, your code solved my problem.
If you don’t mind, can you help me solve a few further problems? Modified on the basis of this code to achieve the following 4 purposes:



The first one: The data in column D generated by the code is named path, but all the addresses in this column know the folder, and now I want to modify the path of each file to the full path name, that is, there is a file after the original path file name. That is to say, this path is a hyperlink and you can click to open the file directly, but the data in column D shows the complete path.



The second one: add an E column named the creation date of the file. After traversing each file, the creation date of each corresponding file is generated in this column.



Third: Add a column F named file modification date. After traversing each file, the last modification date of each corresponding file is generated in this column.



Fourth: Add a G column named file size, and generate the file size of each corresponding file in this column after traversing each file.

Thanks again, hope to help me!
Reply With Quote
  #4  
Old 09-25-2020, 09:36 AM
NoSparks NoSparks is offline How to modify the code to meet the corresponding requirements Windows 10 How to modify the code to meet the corresponding requirements Office 2010
Excel Hobbyist
 
Join Date: Nov 2013
Location: British Columbia, Canada
Posts: 831
NoSparks is just really niceNoSparks is just really niceNoSparks is just really niceNoSparks is just really niceNoSparks is just really nice
Default

I don't follow what the first one is but in this code the hyperlink is put in Column D and the file name with extension is displayed.

Code:
    Dim jg(), k&, tms#
    
    Sub ListFilesFso()
    sb& = InputBox("Search Type: AllFiles=0/Files=1/Folder=-1/All Folder=-2", "Find Files", 0)
    SpFile$ = InputBox("typeoffiles", "Find Files", ".xl")
    If SpFile Like ".*" Then SpFile = LCase(SpFile) & "*"
    With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
    ReDim jg(65535, 6)
    jg(0, 0) = "Ext": jg(0, 1) = IIf(sb < 0, IIf(Len(SpFile), "Filename", "No"), "Filename")
    jg(0, 2) = "Folder": jg(0, 3) = "Path": jg(0, 4) = "Creation Date": jg(0, 5) = "Modification Date": jg(0, 6) = "File Size"
    tms = Timer: k = 0: Call ListAllFso(myPath, sb, SpFile)
    If sb < 0 And Len(SpFile) = 0 Then Application.StatusBar = "Get " & k & " Folders."
    [a1].CurrentRegion = "": [a1].Resize(k + 1, 7) = jg: [a1].CurrentRegion.AutoFilter Field:=1
    ' add hyperlinks
        With ActiveSheet
        'hyperlinks in column B
            'For Each cel In .Range("B2", .Range("B" & .Rows.Count).End(xlUp))
            '    .Hyperlinks.Add Anchor:=.Cells(cel.Row, cel.Column), Address:=cel.Offset(, 2) & "/" & cel & cel.Offset(, -1)
            'Next cel
        'hyperlinks in column D
            For Each cel In .Range("D2", .Range("D" & .Rows.Count).End(xlUp))
                .Hyperlinks.Add Anchor:=.Cells(cel.Row, cel.Column), Address:=cel & "/" & cel.Offset(, -2) & cel.Offset(, -3), TextToDisplay:=cel.Offset(, -2).Value & cel.Offset(, -3).Value
            Next cel
        End With
        
    End Sub
    
    Function ListAllFso(myPath$, Optional sb& = 0, Optional SpFile$ = "")
    Set fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
    On Error Resume Next
    If sb >= 0 Or Len(SpFile) Then
    For Each f In fld.Files
    t = False
    n = InStrRev(f.Name, "."): fnm = Left(f.Name, n - 1): x = LCase(Mid(f.Name, n))
    If Err.Number Then Err.Clear
    If SpFile = " " Then
    t = True
    ElseIf SpFile Like ".*" Then
    If x Like SpFile Then t = True
    Else
    If InStr(fnm, SpFile) Then t = True
    End If
    If t Then k = k + 1: jg(k, 0) = x: jg(k, 1) = "'" & fnm: jg(k, 2) = fld.Name: jg(k, 3) = fld.Path: jg(k, 4) = f.DateCreated: jg(k, 5) = f.DateLastModified: jg(k, 6) = f.Size
    Next
    Application.StatusBar = Format(Timer - tms, "0.0s") & " Get " & k & " Files , Searching in Folder ... " & fld.Path
    End If
    For Each fd In fld.SubFolders
    If sb < 0 And Len(SpFile) = 0 Then k = k + 1: jg(k, 0) = "fld": jg(k, 1) = k: jg(k, 2) = fd.Name: jg(k, 3) = fld.Path: jg(k, 4) = f.DateCreated: jg(k, 5) = f.DateLastModified: jg(k, 6) = f.Size
    If sb Mod 2 = 0 Then Call ListAllFso(fd.Path, sb, SpFile)
    Next
    End Function
Reply With Quote
  #5  
Old 09-25-2020, 05:53 PM
leeqiang leeqiang is offline How to modify the code to meet the corresponding requirements Windows 10 How to modify the code to meet the corresponding requirements Office 2019
Advanced Beginner
How to modify the code to meet the corresponding requirements
 
Join Date: Aug 2020
Posts: 53
leeqiang is on a distinguished road
Default

Quote:
Originally Posted by NoSparks View Post
I don't follow what the first one is but in this code the hyperlink is put in Column D and the file name with extension is displayed.

Code:
    Dim jg(), k&, tms#
    
    Sub ListFilesFso()
    sb& = InputBox("Search Type: AllFiles=0/Files=1/Folder=-1/All Folder=-2", "Find Files", 0)
    SpFile$ = InputBox("typeoffiles", "Find Files", ".xl")
    If SpFile Like ".*" Then SpFile = LCase(SpFile) & "*"
    With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
    ReDim jg(65535, 6)
    jg(0, 0) = "Ext": jg(0, 1) = IIf(sb < 0, IIf(Len(SpFile), "Filename", "No"), "Filename")
    jg(0, 2) = "Folder": jg(0, 3) = "Path": jg(0, 4) = "Creation Date": jg(0, 5) = "Modification Date": jg(0, 6) = "File Size"
    tms = Timer: k = 0: Call ListAllFso(myPath, sb, SpFile)
    If sb < 0 And Len(SpFile) = 0 Then Application.StatusBar = "Get " & k & " Folders."
    [a1].CurrentRegion = "": [a1].Resize(k + 1, 7) = jg: [a1].CurrentRegion.AutoFilter Field:=1
    ' add hyperlinks
        With ActiveSheet
        'hyperlinks in column B
            'For Each cel In .Range("B2", .Range("B" & .Rows.Count).End(xlUp))
            '    .Hyperlinks.Add Anchor:=.Cells(cel.Row, cel.Column), Address:=cel.Offset(, 2) & "/" & cel & cel.Offset(, -1)
            'Next cel
        'hyperlinks in column D
            For Each cel In .Range("D2", .Range("D" & .Rows.Count).End(xlUp))
                .Hyperlinks.Add Anchor:=.Cells(cel.Row, cel.Column), Address:=cel & "/" & cel.Offset(, -2) & cel.Offset(, -3), TextToDisplay:=cel.Offset(, -2).Value & cel.Offset(, -3).Value
            Next cel
        End With
        
    End Sub
    
    Function ListAllFso(myPath$, Optional sb& = 0, Optional SpFile$ = "")
    Set fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
    On Error Resume Next
    If sb >= 0 Or Len(SpFile) Then
    For Each f In fld.Files
    t = False
    n = InStrRev(f.Name, "."): fnm = Left(f.Name, n - 1): x = LCase(Mid(f.Name, n))
    If Err.Number Then Err.Clear
    If SpFile = " " Then
    t = True
    ElseIf SpFile Like ".*" Then
    If x Like SpFile Then t = True
    Else
    If InStr(fnm, SpFile) Then t = True
    End If
    If t Then k = k + 1: jg(k, 0) = x: jg(k, 1) = "'" & fnm: jg(k, 2) = fld.Name: jg(k, 3) = fld.Path: jg(k, 4) = f.DateCreated: jg(k, 5) = f.DateLastModified: jg(k, 6) = f.Size
    Next
    Application.StatusBar = Format(Timer - tms, "0.0s") & " Get " & k & " Files , Searching in Folder ... " & fld.Path
    End If
    For Each fd In fld.SubFolders
    If sb < 0 And Len(SpFile) = 0 Then k = k + 1: jg(k, 0) = "fld": jg(k, 1) = k: jg(k, 2) = fd.Name: jg(k, 3) = fld.Path: jg(k, 4) = f.DateCreated: jg(k, 5) = f.DateLastModified: jg(k, 6) = f.Size
    If sb Mod 2 = 0 Then Call ListAllFso(fd.Path, sb, SpFile)
    Next
    End Function



Thank you very much for your help. There are some deviations from my needs, but I did not express it clearly:


1. Column B is the file name plus the corresponding hyperlink. I can click on the file name to open the corresponding file.

2. Column D is the full path of the corresponding file, and the generated result is similar to this:
C:\Users\86134\Desktop\OneDrive\Database\Books\eco nomic.pdf

3. The file size displayed in column G is best to use MB as the unit, and the result generated by the corresponding file size is similar to: 8MB

Thank you again for your hard work and help me!
Reply With Quote
  #6  
Old 09-25-2020, 09:15 PM
NoSparks NoSparks is offline How to modify the code to meet the corresponding requirements Windows 10 How to modify the code to meet the corresponding requirements Office 2010
Excel Hobbyist
 
Join Date: Nov 2013
Location: British Columbia, Canada
Posts: 831
NoSparks is just really niceNoSparks is just really niceNoSparks is just really niceNoSparks is just really niceNoSparks is just really nice
Default

This should do it
Code:
    Dim jg(), k&, tms#
    
Sub ListFilesFso()
    sb& = InputBox("Search Type: AllFiles=0/Files=1/Folder=-1/All Folder=-2", "Find Files", 0)
    SpFile$ = InputBox("typeoffiles", "Find Files", ".xl")
    If SpFile Like ".*" Then SpFile = LCase(SpFile) & "*"
    With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
    ReDim jg(65535, 6)
    jg(0, 0) = "Ext": jg(0, 1) = IIf(sb < 0, IIf(Len(SpFile), "Filename", "No"), "Filename")
    jg(0, 2) = "Folder": jg(0, 3) = "Path": jg(0, 4) = "Creation Date": jg(0, 5) = "Modification Date": jg(0, 6) = "File Size"
    tms = Timer: k = 0: Call ListAllFso(myPath, sb, SpFile)
    If sb < 0 And Len(SpFile) = 0 Then Application.StatusBar = "Get " & k & " Folders."
    [a1].CurrentRegion = "": [a1].Resize(k + 1, 7) = jg: [a1].CurrentRegion.AutoFilter Field:=1
        'hyperlinks in column B
        With ActiveSheet
            For Each cel In .Range("B2", .Range("B" & .Rows.Count).End(xlUp))
                .Hyperlinks.Add Anchor:=.Cells(cel.Row, cel.Column), Address:=cel.Offset(, 2) & "\" & cel & cel.Offset(, -1)
            Next cel
        End With
    Columns.AutoFit
    Intersect(ActiveSheet.UsedRange, Columns(7)).HorizontalAlignment = xlRight
End Sub
    
    
Function ListAllFso(myPath$, Optional sb& = 0, Optional SpFile$ = "")
    Set fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
    On Error Resume Next
    If sb >= 0 Or Len(SpFile) Then
        For Each f In fld.Files
            t = False: n = InStrRev(f.Name, ".")
            fnm = Left(f.Name, n - 1)
            x = LCase(Mid(f.Name, n))
            
            If Err.Number Then Err.Clear
    
            If SpFile = " " Then
                t = True
            ElseIf SpFile Like ".*" Then
                If x Like SpFile Then t = True
            Else
                If InStr(fnm, SpFile) Then t = True
            End If
            
            If t Then
                k = k + 1
                jg(k, 0) = x
                jg(k, 1) = "'" & fnm
                jg(k, 2) = fld.Name
                jg(k, 3) = fld.Path & "\" & fnm & x
                jg(k, 4) = f.DateCreated
                jg(k, 5) = f.DateLastModified:
                fs = f.Size
                    Select Case fs
                        Case 0 To 1023: fs = Format(fs, "0") & "B"
                        Case 1024 To 1048575: fs = Format(fs / 1024, "0") & "KB"
                        Case 1048576 To 1073741823: fs = Format(fs / 1048576, "0") & "MB"
                        Case 1073741824 To 1.11111111111074E+20: fs = Format(fs / 1073741823, "0.00") & "GB"
                    End Select
                jg(k, 6) = fs
            End If
        Next
    Application.StatusBar = Format(Timer - tms, "0.0s") & " Get " & k & " Files , Searching in Folder ... " & fld.Path
    End If
    
    For Each fd In fld.SubFolders
        If sb < 0 And Len(SpFile) = 0 Then
            k = k + 1
            jg(k, 0) = "fld"
            jg(k, 1) = k
            jg(k, 2) = fd.Name
            jg(k, 3) = fld.Path & "\" & fnm & x
            jg(k, 4) = f.DateCreated
            jg(k, 5) = f.DateLastModified
            fs = f.Size
                Select Case fs
                    Case 0 To 1023: fs = Format(fs, "0") & "B"
                    Case 1024 To 1048575: fs = Format(fs / 1024, "0") & "KB"
                    Case 1048576 To 1073741823: fs = Format(fs / 1048576, "0") & "MB"
                    Case 1073741824 To 1.11111111111074E+20: fs = Format(fs / 1073741823, "0.00") & "GB"
                End Select
            jg(k, 6) = fs
        End If
        If sb Mod 2 = 0 Then Call ListAllFso(fd.Path, sb, SpFile)
    Next
End Function
Reply With Quote
  #7  
Old 09-26-2020, 12:18 AM
leeqiang leeqiang is offline How to modify the code to meet the corresponding requirements Windows 10 How to modify the code to meet the corresponding requirements Office 2019
Advanced Beginner
How to modify the code to meet the corresponding requirements
 
Join Date: Aug 2020
Posts: 53
leeqiang is on a distinguished road
Default

Quote:
Originally Posted by NoSparks View Post
This should do it
Code:
    Dim jg(), k&, tms#
    
Sub ListFilesFso()
    sb& = InputBox("Search Type: AllFiles=0/Files=1/Folder=-1/All Folder=-2", "Find Files", 0)
    SpFile$ = InputBox("typeoffiles", "Find Files", ".xl")
    If SpFile Like ".*" Then SpFile = LCase(SpFile) & "*"
    With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
    ReDim jg(65535, 6)
    jg(0, 0) = "Ext": jg(0, 1) = IIf(sb < 0, IIf(Len(SpFile), "Filename", "No"), "Filename")
    jg(0, 2) = "Folder": jg(0, 3) = "Path": jg(0, 4) = "Creation Date": jg(0, 5) = "Modification Date": jg(0, 6) = "File Size"
    tms = Timer: k = 0: Call ListAllFso(myPath, sb, SpFile)
    If sb < 0 And Len(SpFile) = 0 Then Application.StatusBar = "Get " & k & " Folders."
    [a1].CurrentRegion = "": [a1].Resize(k + 1, 7) = jg: [a1].CurrentRegion.AutoFilter Field:=1
        'hyperlinks in column B
        With ActiveSheet
            For Each cel In .Range("B2", .Range("B" & .Rows.Count).End(xlUp))
                .Hyperlinks.Add Anchor:=.Cells(cel.Row, cel.Column), Address:=cel.Offset(, 2) & "\" & cel & cel.Offset(, -1)
            Next cel
        End With
    Columns.AutoFit
    Intersect(ActiveSheet.UsedRange, Columns(7)).HorizontalAlignment = xlRight
End Sub
    
    
Function ListAllFso(myPath$, Optional sb& = 0, Optional SpFile$ = "")
    Set fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
    On Error Resume Next
    If sb >= 0 Or Len(SpFile) Then
        For Each f In fld.Files
            t = False: n = InStrRev(f.Name, ".")
            fnm = Left(f.Name, n - 1)
            x = LCase(Mid(f.Name, n))
            
            If Err.Number Then Err.Clear
    
            If SpFile = " " Then
                t = True
            ElseIf SpFile Like ".*" Then
                If x Like SpFile Then t = True
            Else
                If InStr(fnm, SpFile) Then t = True
            End If
            
            If t Then
                k = k + 1
                jg(k, 0) = x
                jg(k, 1) = "'" & fnm
                jg(k, 2) = fld.Name
                jg(k, 3) = fld.Path & "\" & fnm & x
                jg(k, 4) = f.DateCreated
                jg(k, 5) = f.DateLastModified:
                fs = f.Size
                    Select Case fs
                        Case 0 To 1023: fs = Format(fs, "0") & "B"
                        Case 1024 To 1048575: fs = Format(fs / 1024, "0") & "KB"
                        Case 1048576 To 1073741823: fs = Format(fs / 1048576, "0") & "MB"
                        Case 1073741824 To 1.11111111111074E+20: fs = Format(fs / 1073741823, "0.00") & "GB"
                    End Select
                jg(k, 6) = fs
            End If
        Next
    Application.StatusBar = Format(Timer - tms, "0.0s") & " Get " & k & " Files , Searching in Folder ... " & fld.Path
    End If
    
    For Each fd In fld.SubFolders
        If sb < 0 And Len(SpFile) = 0 Then
            k = k + 1
            jg(k, 0) = "fld"
            jg(k, 1) = k
            jg(k, 2) = fd.Name
            jg(k, 3) = fld.Path & "\" & fnm & x
            jg(k, 4) = f.DateCreated
            jg(k, 5) = f.DateLastModified
            fs = f.Size
                Select Case fs
                    Case 0 To 1023: fs = Format(fs, "0") & "B"
                    Case 1024 To 1048575: fs = Format(fs / 1024, "0") & "KB"
                    Case 1048576 To 1073741823: fs = Format(fs / 1048576, "0") & "MB"
                    Case 1073741824 To 1.11111111111074E+20: fs = Format(fs / 1073741823, "0.00") & "GB"
                End Select
            jg(k, 6) = fs
        End If
        If sb Mod 2 = 0 Then Call ListAllFso(fd.Path, sb, SpFile)
    Next
End Function

Very grateful for your help.

There was a problem when running the code. Clicking on the file name in column B could not open the corresponding file and a dialog box popped up, as shown in the figure.

Thank you!

20200926151340.png
Reply With Quote
  #8  
Old 09-26-2020, 06:14 AM
NoSparks NoSparks is offline How to modify the code to meet the corresponding requirements Windows 10 How to modify the code to meet the corresponding requirements Office 2010
Excel Hobbyist
 
Join Date: Nov 2013
Location: British Columbia, Canada
Posts: 831
NoSparks is just really niceNoSparks is just really niceNoSparks is just really niceNoSparks is just really niceNoSparks is just really nice
Default

Oops, forgot to adjust the build of the hyperlinks after altering column D to be the full path, just needs to be
Code:
    .Hyperlinks.Add Anchor:=.Cells(cel.Row, cel.Column), Address:=cel.Offset(, 2)
Reply With Quote
  #9  
Old 09-26-2020, 04:42 PM
leeqiang leeqiang is offline How to modify the code to meet the corresponding requirements Windows 10 How to modify the code to meet the corresponding requirements Office 2019
Advanced Beginner
How to modify the code to meet the corresponding requirements
 
Join Date: Aug 2020
Posts: 53
leeqiang is on a distinguished road
Default

Quote:
Originally Posted by NoSparks View Post
Oops, forgot to adjust the build of the hyperlinks after altering column D to be the full path, just needs to be
Code:
    .Hyperlinks.Add Anchor:=.Cells(cel.Row, cel.Column), Address:=cel.Offset(, 2)
Dim jg(), k&, tms#

Sub ListFilesFso()
sb& = InputBox("Search Type: AllFiles=0/Files=1/Folder=-1/All Folder=-2", "Find Files", 0)
SpFile$ = InputBox("typeoffiles", "Find Files", ".xl")
If SpFile Like ".*" Then SpFile = LCase(SpFile) & "*"
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
End With
If Right(myPath, 1) <> "" Then myPath = myPath & ""
ReDim jg(65535, 6)
jg(0, 0) = "Ext": jg(0, 1) = IIf(sb < 0, IIf(Len(SpFile), "Filename", "No"), "Filename")
jg(0, 2) = "Folder": jg(0, 3) = "Path": jg(0, 4) = "Creation Date": jg(0, 5) = "Modification Date": jg(0, 6) = "File Size"
tms = Timer: k = 0: Call ListAllFso(myPath, sb, SpFile)
If sb < 0 And Len(SpFile) = 0 Then Application.StatusBar = "Get " & k & " Folders."
[a1].CurrentRegion = "": [a1].Resize(k + 1, 7) = jg: [a1].CurrentRegion.AutoFilter Field:=1
' add hyperlinks
With ActiveSheet
'hyperlinks in column B
For Each cel In .Range("B2", .Range("B" & .Rows.Count).End(xlUp))
.Hyperlinks.Add Anchor:=.Cells(cel.Row, cel.Column), Address:=cel.Offset(, 2) ' & "/" & cel & cel.Offset(, -1)
Next cel
'hyperlinks in column D
'For Each cel In .Range("D2", .Range("D" & .Rows.Count).End(xlUp))
'.Hyperlinks.Add Anchor:=.Cells(cel.Row, cel.Column), Address:=cel & "/" & cel.Offset(, -2) & cel.Offset(, -3), TextToDisplay:=cel.Offset(, -2).Value & cel.Offset(, -3).Value
'Next cel
End With

End Sub

Function ListAllFso(myPath$, Optional sb& = 0, Optional SpFile$ = "")
Set fld = CreateObject("Scripting.FileSystemObject").GetFold er(myPath)
On Error Resume Next
If sb >= 0 Or Len(SpFile) Then
For Each f In fld.Files
t = False
n = InStrRev(f.Name, "."): fnm = Left(f.Name, n - 1): x = LCase(Mid(f.Name, n))
If Err.Number Then Err.Clear
If SpFile = " " Then
t = True
ElseIf SpFile Like ".*" Then
If x Like SpFile Then t = True
Else
If InStr(fnm, SpFile) Then t = True
End If
If t Then k = k + 1: jg(k, 0) = x: jg(k, 1) = "'" & fnm: jg(k, 2) = fld.Name: jg(k, 3) = f.Path: jg(k, 4) = f.DateCreated: jg(k, 5) = f.DateLastModified: jg(k, 6) = Format(f.Size / 1048576, "0.00MB") 'f.Size
Next
Application.StatusBar = Format(Timer - tms, "0.0s") & " Get " & k & " Files , Searching in Folder ... " & fld.Path
End If
For Each fd In fld.SubFolders
If sb < 0 And Len(SpFile) = 0 Then k = k + 1: jg(k, 0) = "fld": jg(k, 1) = k: jg(k, 2) = fd.Name: jg(k, 3) = f.Path: jg(k, 4) = f.DateCreated: jg(k, 5) = f.DateLastModified: jg(k, 6) = Format(f.Size / 1048576, "0.00MB") ' f.Size
If sb Mod 2 = 0 Then Call ListAllFso(fd.Path, sb, SpFile)
Next
End Function







Very grateful for your help. The problem is solved, I wish you happiness!
Reply With Quote
  #10  
Old 04-17-2022, 01:56 AM
leeqiang leeqiang is offline How to modify the code to meet the corresponding requirements Windows 10 How to modify the code to meet the corresponding requirements Office 2019
Advanced Beginner
How to modify the code to meet the corresponding requirements
 
Join Date: Aug 2020
Posts: 53
leeqiang is on a distinguished road
Default

Code:
Dim jg(), k&, tms#
   
    Sub ListFilesFso()
    sb& = InputBox("Search Type: AllFiles=0/Files=1/Folder=-1/All Folder=-2", "Find Files", 0)
    SpFile$ = InputBox("typeoffiles", "Find Files", ".xl")
    If SpFile Like ".*" Then SpFile = LCase(SpFile) & "*"
    With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
    ReDim jg(65535, 6)
    jg(0, 0) = "Ext": jg(0, 1) = IIf(sb < 0, IIf(Len(SpFile), "Filename", "No"), "Filename")
    jg(0, 2) = "Folder": jg(0, 3) = "Path": jg(0, 4) = "Creation Date": jg(0, 5) = "Modification Date": jg(0, 6) = "File Size"
    tms = Timer: k = 0: Call ListAllFso(myPath, sb, SpFile)
    If sb < 0 And Len(SpFile) = 0 Then Application.StatusBar = "Get " & k & " Folders."
    [a1].CurrentRegion = "": [a1].Resize(k + 1, 7) = jg: [a1].CurrentRegion.AutoFilter Field:=1
    ' add hyperlinks
        With ActiveSheet
        'hyperlinks in column B
            For Each cel In .Range("B2", .Range("B" & .Rows.Count).End(xlUp))
                .Hyperlinks.Add Anchor:=.Cells(cel.Row, cel.Column), Address:=cel.Offset(, 2) ' & "/" & cel & cel.Offset(, -1)
            Next cel
        'hyperlinks in column D
            'For Each cel In .Range("D2", .Range("D" & .Rows.Count).End(xlUp))
                '.Hyperlinks.Add Anchor:=.Cells(cel.Row, cel.Column), Address:=cel & "/" & cel.Offset(, -2) & cel.Offset(, -3), TextToDisplay:=cel.Offset(, -2).Value & cel.Offset(, -3).Value
            'Next cel
        End With
        
    End Sub
   
    Function ListAllFso(myPath$, Optional sb& = 0, Optional SpFile$ = "")
    Set fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
    On Error Resume Next
    If sb >= 0 Or Len(SpFile) Then
    For Each f In fld.Files
    t = False
    n = InStrRev(f.Name, "."): fnm = Left(f.Name, n - 1): x = LCase(Mid(f.Name, n))
    If Err.Number Then Err.Clear
    If SpFile = " " Then
    t = True
    ElseIf SpFile Like ".*" Then
    If x Like SpFile Then t = True
    Else
    If InStr(fnm, SpFile) Then t = True
    End If
    If t Then k = k + 1: jg(k, 0) = x: jg(k, 1) = "'" & fnm: jg(k, 2) = fld.Name: jg(k, 3) = f.Path: jg(k, 4) = f.DateCreated: jg(k, 5) = f.DateLastModified: jg(k, 6) = Format(f.Size / 1048576, "0.00MB")  'f.Size
    Next
    Application.StatusBar = Format(Timer - tms, "0.0s") & " Get " & k & " Files , Searching in Folder ... " & fld.Path
    End If
    For Each fd In fld.SubFolders
    If sb < 0 And Len(SpFile) = 0 Then k = k + 1: jg(k, 0) = "fld": jg(k, 1) = k: jg(k, 2) = fd.Name: jg(k, 3) = f.Path: jg(k, 4) = f.DateCreated: jg(k, 5) = f.DateLastModified: jg(k, 6) = Format(f.Size / 1048576, "0.00MB") ' f.Size
    If sb Mod 2 = 0 Then Call ListAllFso(fd.Path, sb, SpFile)
    Next
    End Function
Reply With Quote
  #11  
Old 04-17-2022, 03:30 AM
leeqiang leeqiang is offline How to modify the code to meet the corresponding requirements Windows 10 How to modify the code to meet the corresponding requirements Office 2019
Advanced Beginner
How to modify the code to meet the corresponding requirements
 
Join Date: Aug 2020
Posts: 53
leeqiang is on a distinguished road
Default

Code:
Dim jg(), k&, tms#
   
    Sub ListFilesFso()
    sb& = InputBox("Search Type: AllFiles=0/Files=1/Folder=-1/All Folder=-2", "Find Files", 0)
    SpFile$ = InputBox("typeoffiles", "Find Files", " ")
    If SpFile Like ".*" Then SpFile = LCase(SpFile) & "*"
    With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
    ReDim jg(65535, 6)
    jg(0, 0) = "Ext": jg(0, 1) = IIf(sb < 0, IIf(Len(SpFile), "Filename", "No"), "Filename")
    jg(0, 2) = "Folder": jg(0, 3) = "Path": jg(0, 4) = "Creation Date": jg(0, 5) = "Modification Date": jg(0, 6) = "File Size"
    tms = Timer: k = 0: Call ListAllFso(myPath, sb, SpFile)
    If sb < 0 And Len(SpFile) = 0 Then Application.StatusBar = "Get " & k & " Folders."
    [a1].CurrentRegion = "": [a1].Resize(k + 1, 7) = jg: [a1].CurrentRegion.AutoFilter Field:=1
    ' add hyperlinks
        With ActiveSheet
        'hyperlinks in column B
            For Each cel In .Range("B2", .Range("B" & .Rows.Count).End(xlUp))
                .Hyperlinks.Add Anchor:=.Cells(cel.Row, cel.Column), Address:=cel.Offset(, 2) ' & "/" & cel & cel.Offset(, -1)
            Next cel
        'hyperlinks in column D
            'For Each cel In .Range("D2", .Range("D" & .Rows.Count).End(xlUp))
                '.Hyperlinks.Add Anchor:=.Cells(cel.Row, cel.Column), Address:=cel & "/" & cel.Offset(, -2) & cel.Offset(, -3), TextToDisplay:=cel.Offset(, -2).Value & cel.Offset(, -3).Value
            'Next cel
        End With
        
    End Sub
   
    Function ListAllFso(myPath$, Optional sb& = 0, Optional SpFile$ = "")
    Set fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
    On Error Resume Next
    If sb >= 0 Or Len(SpFile) Then
    For Each f In fld.Files
    t = False
    n = InStrRev(f.Name, "."): fnm = Left(f.Name, n - 1): x = LCase(Mid(f.Name, n))
    If Err.Number Then Err.Clear
    If SpFile = " " Then
    t = True
    ElseIf SpFile Like ".*" Then
    If x Like SpFile Then t = True
    Else
    If InStr(fnm, SpFile) Then t = True
    End If
    If t Then k = k + 1: jg(k, 0) = x: jg(k, 1) = "'" & fnm: jg(k, 2) = fld.Name: jg(k, 3) = f.Path: jg(k, 4) = f.DateCreated: jg(k, 5) = f.DateLastModified: jg(k, 6) = Format(f.Size / 1048576, "0.00MB")  'f.Size
    Next
    Application.StatusBar = Format(Timer - tms, "0.0s") & " Get " & k & " Files , Searching in Folder ... " & fld.Path
    End If
    For Each fd In fld.SubFolders
    If sb < 0 And Len(SpFile) = 0 Then k = k + 1: jg(k, 0) = "fld": jg(k, 1) = k: jg(k, 2) = fd.Name: jg(k, 3) = f.Path: jg(k, 4) = f.DateCreated: jg(k, 5) = f.DateLastModified: jg(k, 6) = Format(f.Size / 1048576, "0.00MB") ' f.Size
    If sb Mod 2 = 0 Then Call ListAllFso(fd.Path, sb, SpFile)
    Next
    End Function
Reply With Quote
Reply

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Add file name automatically in the vba code ... LearnerExcel Excel 3 12-30-2019 06:11 AM
How to modify the code to meet the corresponding requirements vb code for updating file automatically klpw Excel Programming 1 01-14-2016 08:05 PM
How to modify the code to meet the corresponding requirements Auto Save Every Page(s) as a separate file, and name each new file automatically by the first line? commissarmo Word VBA 3 03-14-2015 12:53 AM
How to modify the code to meet the corresponding requirements How to convert a text file to an Excel file with the data format automatically? mradmin Excel 6 10-16-2013 10:34 AM
How to modify the code to meet the corresponding requirements How to copy automatically data from Excel file to Word file? fuchsd Word 6 10-25-2011 05:52 AM

Other Forums: Access Forums

All times are GMT -7. The time now is 02:51 PM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft