ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[求助] 请教遍历文件夹及子文件夹的Excel文件

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2012-8-6 15:14 | 显示全部楼层 |阅读模式
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖已被收录到知识树中,索引项:文件操作和FSO
我想通过VBA代码来遍历D盘的所有文件夹及子文件夹,
查找里面的所有Excel文件以及相应文件的最后修改时间。
希望返回的结果中带有文件路径,
代码最好能对2003-2010各版本都适用。

脚本语言也可以,希望效率能比较高一些。

请老师帮忙提供一段代码,谢谢!

TA的精华主题

TA的得分主题

 楼主| 发表于 2012-8-6 16:02 | 显示全部楼层
本帖最后由 leroy 于 2012-8-6 16:03 编辑

请问各位老师,
以下是我刚刚找到的代码。
这段代码能够通过修改,限定为仅搜索Excel文件吗?

[code=vb]
'VBE--工具--引用--找到miscrosoft scription runtime项目并选中
Dim ArrFiles(1 To 10000) '创建一个数组空间,用来存放文件名称
Dim cntFiles% '文件个数

Public Sub ListAllFiles()
Dim strPath$ '声明文件路径
Dim i%
Dim fso As New FileSystemObject, fd As Folder
strPath = ThisWorkbook.Path & "\"
cntFiles = 0
Set fd = fso.GetFolder(strPath)
SearchFiles fd
Sheets(1).Range("A1").Resize(cntFiles) = Application.Transpose(ArrFiles)
End Sub

Sub SearchFiles(ByVal fd As Folder)
Dim fl As File
Dim sfd As Folder
For Each fl In fd.Files
cntFiles = cntFiles + 1
ArrFiles(cntFiles) = fl.Path
Next fl
If fd.SubFolders.Count = 0 Then Exit Sub
For Each sfd In fd.SubFolders
SearchFiles sfd
Next
End Sub[/code]

TA的精华主题

TA的得分主题

发表于 2012-8-6 16:51 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2012-8-6 17:26 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助

TA的精华主题

TA的得分主题

发表于 2012-8-6 19:35 | 显示全部楼层
本帖最后由 joforn 于 2012-8-30 23:21 编辑

  1. Option Explicit


  2. Private Declare Function PathIsDirectoryEmptyW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long
  3. Private Declare Function PathAddBackslashW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long
  4. Private Declare Function PathIsDirectoryW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long
  5. Private Declare Function PathFindExtension Lib "shlwapi.dll" Alias "PathFindExtensionW" (ByVal pszPath As Long) As Long

  6. Private Declare Function GetFileTimeAPI Lib "kernel32" Alias "GetFileTime" (ByVal hFile As Long, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
  7. Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
  8. Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long

  9. Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileW" (ByVal lpFileName As Long, lpFindFileData As WIN32_FIND_DATA) As Long
  10. Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileW" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Boolean
  11. Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long

  12. Private Declare Sub CopyMemoryString Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)


  13. Private Const INVALID_HANDLE_VALUE  As Long = -1&
  14. Private Const MAX_PATH          As Long = 260

  15. Private Type FILETIME
  16.     dwLowDateTime     As Long
  17.     dwHighDateTime    As Long
  18. End Type

  19. Private Type SYSTEMTIME
  20.     wYear             As Integer
  21.     wMonth            As Integer
  22.     wDayOfWeek        As Integer
  23.     wDay              As Integer
  24.     wHour             As Integer
  25.     wMinute           As Integer
  26.     wSecond           As Integer
  27.     wMilliseconds     As Integer
  28. End Type

  29. Private Type WIN32_FIND_DATA
  30.     dwFileAttributes        As Long     ' 文件属性
  31.     ftCreationTime          As FILETIME ' 文件创建时间
  32.     ftLastAccessTime        As FILETIME ' 文件最后一次访问时间
  33.     ftLastWriteTime         As FILETIME ' 文件最后一次修改时间
  34.     nFileSizeHigh           As Long     ' 文件长度高32位
  35.     nFileSizeLow            As Long     ' 文件长度低32位
  36.     dwReserved0             As Long     ' 系统保留
  37.     dwReserved1             As Long     ' 系统保留
  38.     cFileName(MAX_PATH * 2) As Byte     ' 长文件名
  39.     cAlternate(14 * 2)      As Byte     ' 8.3格式文件名
  40. End Type

  41. Private blnExtension  As Boolean
  42. Private ExtList()     As String
  43. Private blnFind       As Boolean

  44. Public Event FindBegin()
  45. Public Event FindEnd()

  46. Public Event FindedFile(ByVal FileName As String, ByVal CreationTime As Date, ByVal LastAccessTime As Date, ByVal LastWriteTime As Date)

  47. Public Sub FileSearch(ByVal DirName As String, Optional ByVal ScanSubDir As Boolean = True)
  48.   Dim FileName    As String
  49.   Dim FindData    As WIN32_FIND_DATA
  50.   Dim hFind       As Long
  51.   Dim I           As Long
  52.   Dim blnFirst    As Boolean
  53.   
  54.   If Not blnFind Then
  55.     blnFind = True
  56.     blnFirst = True
  57.     RaiseEvent FindBegin
  58.   End If
  59.   
  60.   DirName = PathAddBackslash(DirName)
  61.   If PathIsDirectoryW(StrPtr(DirName & vbNullChar)) Then
  62.     If PathIsDirectoryEmptyW(StrPtr(DirName & vbNullChar)) Then Exit Sub
  63.    
  64.     hFind = FindFirstFile(StrPtr(DirName & "*.*" & vbNullChar), FindData)
  65.     If hFind <> INVALID_HANDLE_VALUE Then
  66.       With FindData
  67.         Do
  68.           FileName = .cFileName
  69.           I = InStr(1&, FileName, vbNullChar)
  70.           If I Then FileName = Left$(FileName, I - 1)
  71.           If InStr(1, "..", FileName) Then
  72.             '如果是"."和".."则不做任何处理
  73.           Else
  74.             FileName = DirName & FileName
  75.             If PathIsDirectoryW(StrPtr(FileName & vbNullChar)) Then   ' 查找到的是一个目录名
  76.               If ScanSubDir Then FileSearch FileName, True
  77.             Else
  78.               RaiseFindFile FileName, FindData
  79.             End If
  80.           End If
  81.           DoEvents
  82.         Loop While (FindNextFile(hFind, FindData) <> 0) And blnFind
  83.       End With
  84.     End If
  85.    
  86.     FindClose hFind
  87.     Err.Clear
  88.   End If
  89.   
  90.   If blnFirst Then
  91.     blnFind = False
  92.     RaiseEvent FindEnd
  93.   End If
  94. End Sub

  95. Public Sub SetExtensionList(ByVal Extension As String)
  96.   Dim I As Long
  97.   blnExtension = False
  98.   Extension = Trim$(UCase$(ExtList(I)))
  99.   If Len(Extension) Then
  100.     Extension = Replace(Extension, "|", vbNullChar)
  101.     ExtList = Split(Extension, vbNullChar)
  102.     For I = 0 To UBound(ExtList)
  103.       ExtList(I) = Trim$(ExtList(I))
  104.       If ExtList(I) = "*.*" Then Exit Sub
  105.     Next I
  106.     blnExtension = True
  107.   End If
  108. End Sub

  109. Public Sub CleanExtensionList()
  110.   blnExtension = False
  111.   ReDim ExtList(0)
  112. End Sub

  113. Public Sub StopSearch()
  114.   blnFind = False
  115. End Sub

  116. '在路径后添加一个分隔符""
  117. Private Function PathAddBackslash(ByVal Path As String) As String
  118.   Dim I As Long
  119.   
  120.   Path = Path & String(MAX_PATH, vbNullChar)
  121.   PathAddBackslashW StrPtr(Path)
  122.   I = InStr(Path, vbNullChar)
  123.   If I > 0 Then Path = Left$(Path, I - 1)
  124.   PathAddBackslash = Path
  125. End Function


  126. '从路径提取文件后缀名
  127. Private Function ExtractFileExtension(ByVal Path As String) As String
  128.   Dim I As Long
  129.   
  130.   Path = Path & vbNullChar
  131.   I = PathFindExtension(StrPtr(Path))
  132.   If I Then
  133.     CopyMemoryString StrPtr(Path), I, Len(Path) * 2
  134.     I = InStr(Path, vbNullChar)
  135.     If I > 0 Then Path = Left$(Path, I - 1)
  136.     ExtractFileExtension = Path
  137.   End If
  138. End Function

  139. Private Sub RaiseFindFile(ByVal FileName As String, FindInfo As WIN32_FIND_DATA)
  140.   Dim I As Long, J  As Long
  141.   Dim Extension     As String
  142.   
  143.   With FindInfo
  144.     If blnExtension Then
  145.       Extension = UCase$(ExtractFileExtension(.cFileName))
  146.       J = UBound(ExtList)
  147.       For I = 0 To J
  148.         If ExtList(I) = Extension Then Exit For
  149.       Next I
  150.       If I > J Then Exit Sub
  151.     End If
  152.   
  153.     RaiseEvent FindedFile(FileName, FileTimeToDate(.ftCreationTime), FileTimeToDate(.ftLastAccessTime), FileTimeToDate(.ftLastWriteTime))
  154.   End With
  155. End Sub

  156. '文件时间转换
  157. Private Function FileTimeToDate(lpFileTime As FILETIME) As Date
  158.   Dim lFileTime As FILETIME
  159.   Dim sysTime   As SYSTEMTIME
  160.   
  161.   FileTimeToLocalFileTime lpFileTime, lFileTime
  162.   FileTimeToSystemTime lFileTime, sysTime
  163.   FileTimeToDate = CDate(sysTime.wYear & "-" & sysTime.wMonth & "-" & sysTime.wDay & " " & _
  164.                       sysTime.wHour & ":" & sysTime.wMinute & ":" & sysTime.wSecond)
  165. End Function


  166. Private Sub Class_Initialize()
  167.   ReDim ExtList(0)
  168. End Sub

  169. Private Sub Class_Terminate()
  170.   Erase ExtList
  171. End Sub
复制代码


完整代码示例表: FileSearch.rar (21.46 KB, 下载次数: 733)

评分

3

查看全部评分

TA的精华主题

TA的得分主题

发表于 2012-8-6 19:40 | 显示全部楼层
本帖最后由 joforn 于 2012-8-7 08:24 编辑

说明:
一、如果没有调用过SetExtensionList方法或是在调用搜索前使用了CleanExtensionList方法,则会搜索出所有的文件;
二、用此类搜索时与Office版本无关,但只能在NT5.0以上的Windows版本中运行,不区分64位或32位;
三、调用FileSearch方法时,如果最后一个参数ScanSubDir的值为False时只搜索当前目录,不会搜索子目录,默认为搜索指定目录及其所有子目录;
四、此代码兼容VB6,可以直接导出到VB6工程中使用,无需做其它的修改;
五、如果搜索过程中想取消当前搜索任务,使用StopSearch方法就可以退出当前搜索任务。

TA的精华主题

TA的得分主题

发表于 2012-8-6 20:08 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
刚好自己也用了这个功能,发给你参考一下,使用很简单,会自动提示你选择文件夹,程序自动列出xls和xlsx文件,使用递归方法,速度可能会有点慢。


Public Sub btn8(ByVal control As IRibbonControl)
Rem |---------------------------------------------------------------------------------------------------
Rem |功能:选择文件夹,遍历选定的这个文件夹的所有文件

On Error GoTo Err1

    Dim szPath As String
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "选择文件夹", 0, 0)
    If Not objFolder Is Nothing Then
        szPath = objFolder.self.Path
    Else
        Set objFolder = Nothing
        Set objShell = Nothing
        Exit Sub
    End If
    Set objFolder = Nothing
    Set objShell = Nothing

    SearchFiles szPath, 1
    Exit Sub
   
Err1:
  MsgBox "出错啦!", vbExclamation

End Sub

‘-------------------------------------------------------------------------------------------------
Private Sub SearchFiles(strPath As String, lRow As Long)

On Error GoTo Err1

    Dim oFSO As Object
    Dim oFLD As Object
    Dim oFLS As Object
    Dim oSUB As Object
    Dim szFile As String
   
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFLD = oFSO.GetFolder(strPath)
    For Each oFLS In oFLD.Files
        If GetExName(oFLS.Name) = "xlsx" Or GetExName(oFLS.Name) = "xls" Then
               
            xlapp.Cells(lRow, 1) = oFLD.Path
            xlapp.Cells(lRow, 2) = oFLS.Name
            
            szFile = oFLD.Path & "\" & oFLS.Name            
            lRow = lRow + 1
        End If
    Next

    For Each oSUB In oFLD.SubFolders
        SearchFiles oSUB.Path, lRow
    Next
    Exit Sub

Err1:
  MsgBox "出错啦!", vbExclamation

End Sub

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2012-8-6 20:17 | 显示全部楼层
joforn 发表于 2012-8-6 19:35
下面是包含示例的EXCEL档。

单看5楼这么多API引用,
就知道差距得有多大了。
非常谢谢南宫老师的热心帮助!

TA的精华主题

TA的得分主题

发表于 2012-8-6 21:22 | 显示全部楼层
Sub 获取D盘中所有Excel文件()  '包括子目录
    With CreateObject("WScript.Shell")
     .Popup .Exec("cmd.exe /c dir/s d:\*.xl*").StdOut.ReadAll, , "显示目录"
    End With
End Sub

可以参考这个代码改改DIR命令就行了

评分

2

查看全部评分

TA的精华主题

TA的得分主题

发表于 2012-8-10 23:37 | 显示全部楼层
无意中发现,自己第一个API函数的声明不小心写错了。
虽然对程序的运行结果没有影响,但会导致程序在处理时多花费时间,五楼的代码和附件已经重新修正。
手动修正方式:将
Private Declare Function PathIsDirectoryEmptyW Lib "shlwapi.dll" (ByVal pszPath As String) As Long 中的pszPath参数的类型改为Long型、即:
Private Declare Function PathIsDirectoryEmptyW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-29 04:56 , Processed in 0.055211 second(s), 11 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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