#1
|
|||
|
|||
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!
Last edited by leeqiang; 09-24-2020 at 05:07 PM. |
#2
|
|||
|
|||
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 |
#3
|
|||
|
|||
Quote:
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! |
#4
|
|||
|
|||
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 |
#5
|
|||
|
|||
Quote:
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! |
#6
|
|||
|
|||
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 |
#7
|
|||
|
|||
Quote:
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 |
#8
|
|||
|
|||
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) |
#9
|
|||
|
|||
Quote:
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! |
#10
|
|||
|
|||
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 |
#11
|
|||
|
|||
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 |
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 |
vb code for updating file automatically | klpw | Excel Programming | 1 | 01-14-2016 08:05 PM |
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 convert a text file to an Excel file with the data format automatically? | mradmin | Excel | 6 | 10-16-2013 10:34 AM |
How to copy automatically data from Excel file to Word file? | fuchsd | Word | 6 | 10-25-2011 05:52 AM |