[求助]如何用VBA遍历指定目录下的所有子文件夹和文件

xfliuliu2710

大灰狼大师在吗,20楼的问题能否再帮解决一下?谢谢了.

yj304

学习下

yf_992258

再请教大灰狼大师一个问题,如何让程序运行后,在A1单元格以及本工作表名称显示为所选择一级文件夹的名称&"文件清单"?如选择的文件夹名称为"2009年农业资料1",则A1和工作表名称为"2009年农业资料1文件清单",麻烦大师了.

见红色部分，用到“文件清单”的地方全部替换掉，不知道对不对
Sub Test() '使用双字典，旨在提高速度
    Dim MyName, Dic, Did, I, T, F, TT, MyFileName
    'On Error Resume Next
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "选择文件夹", 0, 0)
    If Not objFolder Is Nothing Then lj = objFolder.self.Path & "\"
    Set objFolder = Nothing
    Set objShell = Nothing

    T = Timer
    Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
    Set Did = CreateObject("Scripting.Dictionary")
    Dic.Add (lj), ""
    I = 0
    Do While I < Dic.Count
        Ke = Dic.keys   '开始遍历字典
        MyName = Dir(Ke(I), vbDirectory)    '查找目录
        Do While MyName <> ""
            If MyName <> "." And MyName <> ".." Then
                If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
                    Dic.Add (Ke(I) & MyName & "\"), ""  '就往字典中添加这个次级目录名作为一个条目
                End If
            End If
            MyName = Dir    '继续遍历寻找
        Loop
        I = I + 1
    Loop
    sz = Split(lj, "\")
    Did.Add (sz(UBound(sz) - 1) & ”文件清单“), ""    '以查找D盘下所有EXCEL文件为例
    For Each Ke In Dic.keys
        MyFileName = Dir(Ke & "*.xls")
        Do While MyFileName <> ""
            Did.Add (Ke & MyFileName), ""
            MyFileName = Dir
        Loop
    Next
    For Each Sh In ThisWorkbook.Worksheets
        If Sh.Name = sz(UBound(sz) - 1) & "文件清单" Then
            Sheets(sz(UBound(sz) - 1) & "文件清单").Cells.Delete
            F = True
            Exit For
        Else
            F = False
        End If
    Next
    If Not F Then
        Sheets.Add.Name = sz(UBound(sz) - 1) & "文件清单"
    End If
    Sheets(sz(UBound(sz) - 1) & "文件清单").[A1].Resize(Did.Count, 1) = WorksheetFunction.Transpose(Did.keys)
    TT = Timer - T
    MsgBox TT 'Minute(TT) & "分" & Second(TT) & "秒"
End Sub

xfliuliu2710

非常感谢大灰狼、老朽两位大师,就是这个效果.我自己再摸索下12楼提出的问题，即建立目录与原文件的链接，弄不出来再来求教大师。

[ 本帖最后由 xfliuliu2710 于 2009-8-29 15:12 编辑 ]

xfliuliu2710

ub 建立资料目录'使用双字典，旨在提高速度

Dim MyName, Dic, Did, I, T, F, TT, MyFileName, objShell, objFolder, lj, Ke, sz, Sh, rng As Range, cell As Range
    'On Error Resume Next
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "选择文件夹", 0, 0)
    If Not objFolder Is Nothing Then lj = objFolder.self.Path & "\"
    Set objFolder = Nothing
    Set objShell = Nothing

    T = Timer
    Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
    Set Did = CreateObject("Scripting.Dictionary")
    Dic.Add (lj), ""
    I = 0
    Do While I < Dic.Count
        Ke = Dic.keys   '开始遍历字典
        MyName = Dir(Ke(I), vbDirectory)    '查找目录
        Do While MyName <> ""
            If MyName <> "." And MyName <> ".." Then
                If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
                    Dic.Add (Ke(I) & MyName & "\"), ""  '就往字典中添加这个次级目录名作为一个条目
                End If
            End If
            MyName = Dir    '继续遍历寻找
        Loop
        I = I + 1
    Loop
    sz = Split(lj, "\")
    Did.Add (sz(UBound(sz) - 1) & "文件清单"), "" '以查找D盘下所有EXCEL文件为例
    For Each Ke In Dic.keys
        MyFileName = Dir(Ke & "*.*")
        Do While MyFileName <> ""
            Did.Add (Ke & MyFileName), ""
            MyFileName = Dir
        Loop
    Next
    For Each Sh In ThisWorkbook.Worksheets
        If Sh.Name = sz(UBound(sz) - 1) & "文件清单" Then
            Sheets(sz(UBound(sz) - 1) & "文件清单").Cells.Delete
            F = True
            Exit For
        Else
            F = False
        End If
    Next
    If Not F Then
        Sheets.Add.Name = sz(UBound(sz) - 1) & "文件清单"
    End If
    Sheets(sz(UBound(sz) - 1) & "文件清单").[A1].Resize(Did.Count, 1) = WorksheetFunction.Transpose(Did.keys)
   
   
    j = Did.Count
    Set rng = Range("a2:A" & j)
   For S = 2 To j
  For Each cell In rng
Cells(S, 1).Hyperlinks.Add Anchor:=cell, Address:=lj
Next cell
rng.EntireRow.AutoFit
Next S
Set rng = Nothing

    TT = Timer - T
    MsgBox TT 'Minute(TT) & "分" & Second(TT) & "秒"
End Sub
再请教大灰狼大师帮看看,我这段建立目录与原文件链接的代码(红色字体部分)问题在哪里.点击目录时,首先出现的是"MS OFFICE 安全声明"对话框,点确定后,只能链接到打开一级文件夹.又麻烦你了.

yf_992258

Sub 建立资料目录() '使用双字典，旨在提高速度

Dim MyName, Dic, Did, I, T, F, TT, MyFileName, objShell, objFolder, lj, Ke, sz, Sh, rng As Range, cell As Range
    'On Error Resume Next
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "选择文件夹", 0, 0)
    If Not objFolder Is Nothing Then lj = objFolder.self.Path & "\"
    Set objFolder = Nothing
    Set objShell = Nothing

    T = Timer
    Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
    Set Did = CreateObject("Scripting.Dictionary")
    Dic.Add (lj), ""
    I = 0
    Do While I < Dic.Count
        Ke = Dic.keys   '开始遍历字典
        MyName = Dir(Ke(I), vbDirectory)    '查找目录
        Do While MyName <> ""
            If MyName <> "." And MyName <> ".." Then
                If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
                    Dic.Add (Ke(I) & MyName & "\"), ""  '就往字典中添加这个次级目录名作为一个条目
                End If
            End If
            MyName = Dir    '继续遍历寻找
        Loop
        I = I + 1
    Loop
    sz = Split(lj, "\")
    Did.Add (sz(UBound(sz) - 1) & "文件清单"), "" '以查找D盘下所有EXCEL文件为例
    For Each Ke In Dic.keys
        MyFileName = Dir(Ke & "*.*")
        Do While MyFileName <> ""
            Did.Add (Ke & MyFileName), ""
            MyFileName = Dir
        Loop
    Next
    For Each Sh In ThisWorkbook.Worksheets
        If Sh.Name = sz(UBound(sz) - 1) & "文件清单" Then
            Sheets(sz(UBound(sz) - 1) & "文件清单").Cells.Delete
            F = True
            Exit For
        Else
            F = False
        End If
    Next
    If Not F Then
        Sheets.Add.Name = sz(UBound(sz) - 1) & "文件清单"
    End If
    Sheets(sz(UBound(sz) - 1) & "文件清单").[A1].Resize(Did.Count, 1) = WorksheetFunction.Transpose(Did.keys)
   
    With Sheets(sz(UBound(sz) - 1) & "文件清单")
    j = Did.Count
    Set rng = .Range("a2:A" & j)
    For S = 2 To j
      .Cells(S, 1).Select
      .Cells(S, 1).Hyperlinks.Add Anchor:=Selection, Address:=.Cells(S, 1)
     rng.EntireRow.AutoFit
    Next S
    End With   
    Set rng = Nothing
    TT = Timer - T
    MsgBox TT 'Minute(TT) & "分" & Second(TT) & "秒"
End Sub

xfliuliu2710

非常感谢大灰狼大师,这已经是一款非常完美的实用工具了.

ningyong58

原帖由 zldccmx 于 2008-9-21 00:31 发表
给一个笨笨的办法，使用 DIR!'以查找D:\盘下所有EXCEL文件为例Sub M_dir()'这是一个主模块，中间调用两人子模块，一个遍历指定目录下的所有文件夹，一个遍历文件夹下的所有EXCEL文件&nbsp;&nbsp;&nbsp; Application. ...

学习这段程序。

Lighttools

请参阅 hank2611 “文档目录管理系统”楼主 的程序
http://club.excelhome.net/viewth ... p;extra=&page=1

我认为很不错，功能和 大灰狼老师 的很相近。

大灰狼老师，能否把 hank2611 楼主 的“文档目录管理系统”程序 稍微改动一下？在选取目录框中记忆前一次的值，意思是二次选取目录打开这个选取框时，不需要重新选取打开--〉计算机---〉XX盘：---〉XX目录....（由于计算机有许多盘符和大量目录）

[ 本帖最后由 Lighttools 于 2009-9-1 01:23 编辑 ]

zldccmx

怎么会这样？

Excel Home论坛 提示信息
未定义操作，请返回。

[ 点击这里返回上一页 ]