ExcelHome技术论坛

 找回密码
 免费注册
QQ登录 只需一步,快速开始
   
高效办公必会的Office99uu优优 永久免费,网表让Excel秒变数据库 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! 国内首部Excel函数公式学习大典 职场充电黑科技, Office微99uu优优 免费下载Excel行业应用视频
300集Office 2010微99uu优优 Tableau-数据可视化工具 突破Excel限制,用活字格提高效率 12门Excel免费公开课任你学
你的Excel 201099uu优优学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
12
返回列表 发新帖
楼主: ivccav
打印 上一主题 下一主题

[分享] 获取指定文件夹及其子文件夹下所有文件信息、并做成超链接

[复制链接]
TA的精华主题TA的得分主题
11
 楼主| 发表于 2018-1-13 13:10 | 只看该作者 |楼主
shi7361 发表于 2018-1-13 10:57
用代码也行吧?参照文件在前一列出现了,用代码读取一下文件不可以么?我是这么想的


自定义一个函数:=getdate(B8,1)
1表示创建日期,2表示修改日期


Function getdate(rng As Range, dt As Integer)
    fn = rng.Hyperlinks(1).Address
    With CreateObject("scripting.filesystemobject")
        Set f = .GetFile(fn)
        If dt = 1 Then
            getdate = Format(f.DateCreated, "yyyy/mm/dd hh:mm:ss")
        Else
            getdate = Format(f.DateLastModified, "yyyy/mm/dd hh:mm:ss")
        End If
    End With
End Function

TA的精华主题TA的得分主题
12
 楼主| 发表于 2018-1-13 13:24 | 只看该作者 |楼主
lihuan_ 发表于 2018-1-13 12:06
楼主,问个问题怎么把文件所在的文件夹名称提取出来然后做个路径?做在后面路径后G列呢?

Cells(Rows.C ...

Cells(Rows.Count, 7).End(3).Offset(1)=Left(f.Path, InStrRev(f.Path, "\", -1, 1))
TA的精华主题TA的得分主题
13
 楼主| 发表于 2018-1-13 14:07 | 只看该作者 |楼主
shi7361 发表于 2018-1-13 10:54
如果我的单元格已经通过公式插入了超链接,如何在后面的单元格查找到超链接文件的创建和更新时间?谢谢

已看到你的问题,跟你在这里描述的不一样。已按你的要求写好代码,在附件中。


新建文件夹.zip (22.54 KB, 下载次数: 2)

Sub getproperty()
    Dim r&, c As Range
    r = Range("a" & Rows.Count).End(3).Row
    For Each c In Range("a2:a" & r)
        With CreateObject("scripting.filesystemobject")
            If c.Hyperlinks.Count Then
                Set f = .GetFile(c.Hyperlinks(1).Address)
                c.Offset(, 1) = Format(f.Size / 1048576, "0.00MB")
                c.Offset(, 2) = Mid(f.Name, InStrRev(f.Name, ".", -1, 1) + 1)
                c.Offset(, 3) = f.DateCreated
                c.Offset(, 4) = f.DateLastModified
            End If
        End With
    Next
    Range("a2:e" & r).Sort [e2], xlDescending, , , , , , xlNo
End Sub




TA的精华主题TA的得分主题
14
发表于 2018-1-13 18:20 | 只看该作者
TA的精华主题TA的得分主题
15
 楼主| 发表于 2018-1-13 18:39 | 只看该作者 |楼主
anymole 发表于 2018-1-13 18:20
2016不能运行。。

显示这个窗体只是装饰,对程序功能没有任何影响。
你直接在程序中移除有关该窗体的部分就行了。
(下面3句红色部分)

Sub allfiles()

    Set fdo = Application.FileDialog(msoFileDialogFolderPicker)
    If fdo.Show = -1 Then
        pth = fdo.SelectedItems(1)
    Else
        MsgBox "您没有选择文件夹!按『确定』键结束", vbCritical
        Exit Sub
    End If
    UserForm1.Show 0
    DoEvents
    Application.ScreenUpdating = False
    With ActiveSheet
        .UsedRange.Clear
        .Cells(1, 1) = "文件序号"
        .Cells(1, 2) = "文件名称"
        .Cells(1, 3) = "创建日期"
        .Cells(1, 4) = "修改日期"
        .Cells(1, 5) = "文件类型"
        .Cells(1, 6) = "文件大小"
        Getfd (pth)

        r = .Range("b" & Rows.Count).End(3).Row
        For Each c In .Range("b2:b" & r)
            .Hyperlinks.Add Anchor:=c, Address:=c.Value, TextToDisplay _
            :=Split(c, "\")(UBound(Split(c, "\")))
        Next
        .Range("a1:f" & r).Borders.LineStyle = xlContinuous
        .Range("a1:f" & r).Borders.Weight = xlThin
    End With
    Application.ScreenUpdating = True
    Unload UserForm1
    MsgBox "文件已全部获取!点『确定』键结束"
End Sub

TA的精华主题TA的得分主题
16
发表于 2018-1-14 10:54 | 只看该作者
非常感谢楼主的分享,学习了!
有两个问题需要请教:
1.B列的数据当中我只需要.PDF或者.excel后缀的文件。其它格式的不要怎么操作呢?
2.需要在H列只显示第一级文件夹名称,I列显示H列下级文件夹名称,J列显示I列下级文件夹名称。
这些能直接点开路径。
感激不尽!
批量导入文件的修改时间等信息.rar 543.45 KB, 下载次数: 0
TA的精华主题TA的得分主题
17
 楼主| 发表于 2018-1-14 16:35 | 只看该作者 |楼主
lihuan_ 发表于 2018-1-14 10:54
非常感谢楼主的分享,学习了!
有两个问题需要请教:
1.B列的数据当中我只需要.PDF或者.excel后缀的文件 ...

筛选只是PDF和XLS的文件可以有,逐级显示文件夹路径没有意义,只写了一个筛选文件类型的,并显示该文件所在的文件夹。
想显示每一级文件夹,可以自己用split获取,按“\”分割然后循环就行了,在该程序中,获取最后一列可以用cells(r,columns.count).end(xltoleft).column,其中r是最后一行行号。
获取指定文件夹及其子文件夹下所有文件 副本.zip (26.9 KB, 下载次数: 2)


Sub allfiles()
   
    Set fdo = Application.FileDialog(msoFileDialogFolderPicker)
    If fdo.Show = -1 Then
        pth = fdo.SelectedItems(1)
    Else
        MsgBox "您没有选择文件夹!按『确定』键结束", vbCritical
        Exit Sub
    End If
    UserForm1.Show 0
    DoEvents
    Application.ScreenUpdating = False
    With ActiveSheet
        .UsedRange.Clear
        .Cells(1, 1) = "文件序号"
        .Cells(1, 2) = "文件名称"
        .Cells(1, 3) = "创建日期"
        .Cells(1, 4) = "修改日期"
        .Cells(1, 5) = "文件类型"
        .Cells(1, 6) = "文件大小"
        .Cells(1, 7) = "文件路径"
        Getfd (pth)
   
        r = .Range("b" & Rows.Count).End(3).Row
        .Range("a1:f" & r).Borders.LineStyle = xlContinuous
        .Range("a1:f" & r).Borders.Weight = xlThin
    End With
    Application.ScreenUpdating = True
    Unload UserForm1
    MsgBox "文件已全部获取!点『确定』键结束"
End Sub
Sub Getfd(ByVal pth)
    Set fso = CreateObject("scripting.filesystemobject")
    Set ff = fso.getfolder(pth)
    i = 1
    For Each f In ff.Files
        If InStr("PDF/XLS", UCase(Mid(f.Name, InStrRev(f.Name, ".", -1, 1) + 1))) Then
            r = Cells(Rows.Count, 1).End(3).Offset(1).Row
            Cells(r, 1) = i: i = i + 1
            With Cells(r, 2)
                .Value = f
                .Hyperlinks.Add Anchor:=Cells(r, 2), Address:=.Value, TextToDisplay:=Split(.Value, "\")(UBound(Split(.Value, "\")))
            End With
            Cells(r, 3) = f.DateCreated
            Cells(r, 4) = f.DateLastModified
            Cells(r, 5) = Mid(f.Name, InStrRev(f.Name, ".", -1, 1) + 1)
            Cells(r, 6) = Format(f.Size / 1048576, "0.00MB")
            With Cells(r, 7)
                .Value = ff.Path
                .Hyperlinks.Add Anchor:=Cells(r, 7), Address:=.Value, TextToDisplay:=.Value
            End With
        End If
    Next
    For Each fd In ff.subfolders
        Getfd (fd)
    Next
End Sub

TA的精华主题TA的得分主题
18
发表于 2018-1-14 22:04 | 只看该作者
ivccav 发表于 2018-1-14 16:35
筛选只是PDF和XLS的文件可以有,逐级显示文件夹路径没有意义,只写了一个筛选文件类型的,并显示该文件所 ...

很实用,学习了。谢谢你!!
TA的精华主题TA的得分主题
19
发表于 2018-1-15 07:20 | 只看该作者
您需要登录后才可以回帖 登录 | 免费注册
本版积分规则
关闭

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

关注官方微信,每天坐享新鲜教程
手机版|关于我们|联系我们|ExcelHome    GMT+8, 2018-1-18 17:45 , Processed in 1.092061 second(s), 21 queries , Gzip On.
Powered by Discuz! X3.3 © 2001-2017 Wooffice Inc.
    沪公网安备 31011702000001号 沪ICP备11019229号 本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师
快速回复 返回顶部 返回列表
99uu优优