Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 1721|回复: 3

[已解决]从指定路径提取指定后缀的文档属性,谢谢老司机带带我老师!

[复制链接]
发表于 2016-6-22 10:41 | 显示全部楼层 |阅读模式
本帖最后由 lhj323323 于 2016-6-22 15:57 编辑

老师:
从指定路径提取指定后缀的文档属性
在上传的附件中,本来是可以成功提取的。但后来,发现,当后缀名由3个字符变化到4个字符,以及文件名由1个字符到6个字符后
提取的结果就要报错。请老师有空时,帮我看看,可以怎么修改。先谢谢了

求助.rar (13.6 KB, 下载次数: 8)
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2016-6-22 13:17 | 显示全部楼层    本楼为最佳答案   
代码如下:
  1. Sub 提取()
  2.     Dim fs As Object, fld As Object, fil As Object, f As Object
  3.     Dim p As String
  4.     Dim arr() As Variant
  5.     Dim i As Integer
  6. Application.ScreenUpdating = False
  7.   p = InputBox("请输入或复制指定路径" & Chr(10) & "" & Chr(10) & "" & Chr(10) & "" & Chr(10) & "" & Chr(10) & "以下路径是默认值:" & Chr(10) & "------本模板所在的路径" & Chr(10) & "------<您可将新路径复制此下框内>", "哈哈哈", ActiveWorkbook.Path)
  8.     Set fs = CreateObject("Scripting.FileSystemObject")
  9.     Set fld = fs.getfolder(p)
  10.     Set fil = fld.Files
  11.     ReDim Preserve arr(1 To fil.Count, 1 To 5)
  12.     For Each f In fil
  13.         i = i + 1
  14.         '设置或返回指定文件或文件夹名。读/写属性。
  15.         'arr(i, 1) = f.Name
  16.         arr(i, 1) = Left(f.Name, InStr(f.Name, ".") - 1)
  17.         '返回指定文件或文件夹的创建日期和时间。只读。
  18.         arr(i, 2) = f.DateCreated
  19.         '返回最后一次修改指定文件或文件夹的日期和时间。只读。
  20.         arr(i, 3) = f.DateLastModified
  21.         '返回最后一次访问指定文件或文件夹的日期和时间。只读。
  22.         arr(i, 4) = f.DateLastAccessed
  23.         '根据照片命名的格式,提取第5-13的日期。
  24.         arr(i, 5) = Mid(f.Name, InStr(f.Name, ".") + 1, 9)
  25.     Next f
  26.     With Sheet2
  27.         .Cells.Clear
  28.         .Columns("b:b").NumberFormatLocal = "@"
  29.         .[a1:i1] = Array("批量提取外部文档名称", "原始文档名称", "创建日期", "最后修改日期", "最后访问日期", "新名过渡A", "新名过渡B", "新名A&B", "原始文档路径")
  30.         .Range("B2").Resize(UBound(arr), UBound(arr, 2)) = arr
  31.         .Rows.Font.Name = "宋体"
  32.         .Rows.Font.Size = 10
  33.         .Cells(2, 9) = p  '在[I2]单元格还原用户输入的路径
  34.    End With
  35. Application.ScreenUpdating = True
  36. Sheet2.Activate
  37. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2016-6-22 15:57 | 显示全部楼层
老司机带带我 发表于 2016-6-22 13:17
代码如下:

谢谢老司机带带我老师!
回复

使用道具 举报

发表于 2016-9-2 22:08 | 显示全部楼层
老司机带带我 发表于 2016-6-22 13:17
代码如下:

用VBA如何大提速这个速度太慢

http://www.excelpx.com/thread-424014-1-1.html


回复

使用道具 举报

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

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 09:30 , Processed in 0.536916 second(s), 13 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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