提取文件夹内文件名称，创建时间，最后修改时间等信息

baihaiyang

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

复制代码

程序运行后不报错，也没有反应，求助应该怎样处理。
目标格式如下：

liulang0808

看看这部分吧
Set fs = fso.getfolder("\\hzwx.com\hzwx_share\生产部\生产一分厂\报表\电池箔在线针孔统计\2021年8月在线针孔表\数据明细表").Files

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

baihaiyang

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

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

于箱长

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

baihaiyang

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

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

liulang0808

baihaiyang 发表于 2021-9-15 13:41
文件拷贝到本地之后，变更新的本地路径，程序运行仍旧没有结果。
不报错也没有运行结果出现

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

于箱长

baihaiyang 发表于 2021-9-15 16:54
thisworkbook同路径下的文件、文件夹无法识别

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

shennv

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
    
58. 
    

复制代码