ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 599|回复: 2

[求助] 如何修改代码使生成的D列数据为完整的文件路径?

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-9-26 09:30 | 显示全部楼层 |阅读模式
该代码只在D列生成文件所在文件夹的路径(F:\Books\),没有生成文件的完整路径,想实现生成文件完整的路径如这样的结果:
F:\Books\vba.pdf
请问代码要如何修改?谢谢!


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) = 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) = fld.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



TA的精华主题

TA的得分主题

 楼主| 发表于 2020-9-26 10:13 | 显示全部楼层
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

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-9-26 21:41 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
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
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

最新热点上一条 /1 下一条

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-4-26 11:54 , Processed in 0.035417 second(s), 10 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表