ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
一招顶“一万招”的懒人技巧 Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 112|回复: 7

[求助] 提取文件夹内文件名称,创建时间,最后修改时间等信息

[复制链接]

TA的精华主题

TA的得分主题

发表于 2021-9-15 11:06 | 显示全部楼层 |阅读模式
  1. Sub GetFileTime()
  2.     Dim i As Integer
  3.     Dim fso, fs, f
  4.     i = 1
  5.     Set fso = CreateObject("Scripting.FileSystemObject")
  6.     Set fs = fso.getfolder("\\hzwx.com\hzwx_share\生产部\生产一分厂\报表\电池箔在线针孔统计\2021年8月在线针孔表\数据明细表").Files
  7.     With Sheet1
  8.         .Cells(1, 1) = "序号":
  9.         .Cells(1, 2) = "创建时间":
  10.         .Cells(1, 3) = "最后修改时间":
  11.         .Cells(1, 4) = "最后访问时间"
  12.             For Each f In fs
  13.                 i = i + 1
  14.                 .Cells(i, 1) = f.Name:
  15.                 .Cells(i, 2) = f.datecreated:
  16.                 .Cells(i, 3) = f.DateLastModified:
  17.                 .Cells(i, 4) = f.DateLastAccessed
  18.             Next
  19.     End With
  20. End Sub
复制代码
程序运行后不报错,也没有反应,求助应该怎样处理。
目标格式如下:

目标格式.png

TA的精华主题

TA的得分主题

发表于 2021-9-15 11:52 | 显示全部楼层
看看这部分吧
Set fs = fso.getfolder("\\hzwx.com\hzwx_share\生产部\生产一分厂\报表\电池箔在线针孔统计\2021年8月在线针孔表\数据明细表").Files

或者将文件拷贝到本地,测试看看,然后再确认原因

TA的精华主题

TA的得分主题

 楼主| 发表于 2021-9-15 13:41 | 显示全部楼层
liulang0808 发表于 2021-9-15 11:52
看看这部分吧
Set fs = fso.getfolder("\\hzwx.com\hzwx_share\生产部\生产一分厂\报表\电池箔在线针孔统 ...

文件拷贝到本地之后,变更新的本地路径,程序运行仍旧没有结果。
不报错也没有运行结果出现

TA的精华主题

TA的得分主题

发表于 2021-9-15 13:45 | 显示全部楼层
本帖最后由 于箱长 于 2021-9-15 13:55 编辑

'    Set fs = fso.getfolder("\\hzwx.com\hzwx_share\生产部\生产一分厂\报表\电池箔在线针孔统计\2021年8月在线针孔表\数据明细表").Files
    Set fs = fso.getfolder(ThisWorkbook.Path).Files
上一句,换成下面这句,我这里成功了

TA的精华主题

TA的得分主题

 楼主| 发表于 2021-9-15 16:54 | 显示全部楼层
于箱长 发表于 2021-9-15 13:45
'    Set fs = fso.getfolder("\\hzwx.com\hzwx_share\生产部\生产一分厂\报表\电池箔在线针孔统计\2021年8 ...

thisworkbook同路径下的文件、文件夹无法识别

TA的精华主题

TA的得分主题

发表于 2021-9-15 18:35 | 显示全部楼层
baihaiyang 发表于 2021-9-15 13:41
文件拷贝到本地之后,变更新的本地路径,程序运行仍旧没有结果。
不报错也没有运行结果出现

把完整的模拟文件上传一下

TA的精华主题

TA的得分主题

发表于 2021-9-15 19:19 | 显示全部楼层
baihaiyang 发表于 2021-9-15 16:54
thisworkbook同路径下的文件、文件夹无法识别

把你这个代码所在的文件保存到“数据明细表”文件夹下,然后再打开这个文件执行代码

TA的精华主题

TA的得分主题

发表于 2021-9-15 19:27 | 显示全部楼层
  1. Public Sub GetFlieList()
  2.     On Error Resume Next
  3.     Dim fd As FileDialog
  4.     Set fd = Application.FileDialog(msoFileDialogFolderPicker)
  5.     If fd.Show = -1 Then GetDirectory = fd.SelectedItems(1)
  6.     If IsEmpty(GetDirectory) Then Exit Sub     '如果按取消键,退出
  7.     Dim 父亲()                                          '存放所有文件夹名称及其路径
  8.     Dim 目录, i, k, 文件, x, q, t: t = Timer              '定义变量
  9.     Dim arr1()                                        '存放查找到的所有文件
  10.     Range("a2:h" & Range("a" & Cells.Rows.Count).End(xlUp).Row).ClearContents
  11.     ReDim 父亲(1 To 1)
  12.     ' 父亲(1) = ThisWorkbook.Path & "" '初始化arr,先赋一个值,若需要指定,可用"e:"
  13.     父亲(1) = GetDirectory & ""                        '初始化arr,先赋一个值,若需要指定,可用"e:"
  14.     ' Cells(1, 1) = 父亲(1)  '在A列输出目录
  15.     i = 1: k = 1                                      '初始化i和k的值
  16.     Do While i <= k                                   '循环条件是i小于等于文件夹的个数
  17.         目录 = Dir(父亲(i), vbDirectory)                  '设置搜索位置为数组装入的每一个目录
  18.         Do
  19.             If InStr(目录, ".") = 0 And 目录 <> "" Then   '此用法的缺点是,目录名如果含有"."时,就没有办法显示;默认含"."都是文件
  20.                 k = k + 1                             '当搜索到目录时,目录数自增1
  21.                 ReDim Preserve 父亲(1 To k)
  22.                 父亲(k) = 父亲(i) & 目录 & ""              '将原目录加上新找到的目录合并,作为下一次搜索的位置
  23.                 ' Cells(k, 1) = 父亲(k)
  24.             End If
  25.             目录 = Dir
  26.         Loop Until 目录 = ""                            '当本层搜索完后,跳出循环,进行下一次搜索
  27.         i = i + 1
  28.     Loop
  29.     '*******下面是提取各个文件夹的文件***
  30.     Set fso = CreateObject("Scripting.FileSystemObject")
  31.     For x = 1 To UBound(父亲)
  32.         'If 父亲(x) = "" Then Exit For
  33.         文件 = Dir(父亲(x) & "*.*")                       '设置搜索条件为所有文件
  34.         Do While 文件 <> ""
  35.             q = q + 1
  36.             ReDim Preserve arr1(1 To 6, 1 To q)       '动态扩充数组
  37.             arr1(6, q) = Left(文件, InStrRev(文件, ".") - 1) '文件名
  38.             arr1(5, q) = Left(父亲(x), Len(父亲(x)) - 1)    '上级目录
  39.             Set myFile = fso.GetFile(父亲(x) & 文件)
  40.             arr1(1, q) = 文件   '文件名,有后缀
  41.             arr1(2, q) = myFile.DateCreated '创建日期
  42.             arr1(3, q) = myFile.DateLastModified    '修改日期
  43.             arr1(4, q) = myFile.Size & "KB"   '文件大小
  44.             'arr1(5, q) = myFile.DateLastAccessed    '访问日期
  45.             文件 = Dir
  46.         Loop
  47.     Next x
  48.     ' Stop
  49.     [a1] = "文件名": [b1] = "文件大小": [c1] = "创建日期": [d1] = "修改日期": [e1] = "所在目录": [f1] = "文件名"
  50.     Range("a2").Resize(q, 6) = Application.Transpose(arr1)    '将文件输出
  51.     '添加超链接
  52.     For i = 1 To q
  53.         ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 1, 1), Address:=Cells(i + 1, 6)
  54.         'ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 1, 7), Address:=Cells(i + 1, 7)
  55.     Next
  56.     Debug.Print Timer - t & "秒"
  57. End Sub

复制代码


666.zip

18.23 KB, 下载次数: 10

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,高效办公专列,每天发车

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

GMT+8, 2021-9-20 09:17 , Processed in 0.078811 second(s), 14 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2021 Wooffice Inc.

   

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

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

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