本人小白再求一個遍歷指定文件類型移動其資料夾的代碼

yl.fu

比如 我在a1 中輸入d:\a     執行就可將d:\a下所有資料夾及各子資料夾中含有 “  .nc  ”文件   的文件夾  移動到 d:\a \NC\  下此“NC” 資料夾可判斷沒有就自動創建。謝謝


不知是否可在下面移動文件基礎上改動，求幫助
Sub 入口()
    Call ListDirs([d2].Value, "*.bmp")
End Sub
Sub ListDirs(ByVal strPath As String, ByVal strMatch As String)
    Dim strFileName$, strDstFolder$
    Dim arrPath()
    Dim sPath$
    Dim i&, j&
    If Len(strPath) <= 1 Then Exit Sub
    i = 1: j = 1
    If Right(strPath, 1) Like "[/\]" Then strPath = Left(strPath, Len(strPath) - 1)
    On Error Resume Next
    strDstFolder = strPath & Application.PathSeparator & "图片" & Application.PathSeparator
    MkDir strDstFolder
    On Error GoTo ErrorHandler
    ReDim arrPath(1 To 1)
    arrPath(i) = strPath & Application.PathSeparator
    sPath = arrPath(j)
    Debug.Print sPath
    Do While Len(sPath)
        strFileName = Dir(sPath & "*.*", vbDirectory + vbNormal)
        Do While Len(strFileName)
            If Not (strFileName = "." Or strFileName = "..") Then
                If (GetAttr(sPath & "\" & strFileName) And vbDirectory) = 16 Then
                    '避免读取错误
                    If Err.Number <> 0 Then Err.Clear: GoTo End1If
                    If strFileName <> strDstFolder Then
                        i = i + 1
                        ReDim Preserve arrPath(1 To i)
                        arrPath(i) = sPath & strFileName & Application.PathSeparator
                    End If
                Else
                    If UCase(strFileName) Like UCase(strMatch) Then
                        Name sPath & strFileName As strDstFolder & strFileName
                    End If
                End If
            End If
End1If:
            strFileName = Dir
        Loop
        j = j + 1
        If j > i Then Exit Do
        sPath = arrPath(j)
    Loop
ErrorHandler:
    MsgBox Err.Number & vbCrLf & _
           Err.Description
    Resume Next
End Sub

hwc2ycy

    Call ListDirs([d2].Value, "*.bmp")
改为
    Call ListDirs([d2].Value, "*.nc")

hwc2ycy

1. Sub 入口()
   
2.     Call ListDirs([d2].Value, "*.nc", "nc")
   
3. End Sub
   
4. Sub ListDirs(ByVal strPath As String, ByVal strMatch As String, ByVal strSubFolder As String)
   
5.     Dim strFileName$, strDstFolder$
   
6.     Dim arrPath()
   
7.     Dim sPath$
   
8.     Dim i&, j&
   
9. 
   
10.     If Len(strPath) <= 1 Then Exit Sub
    
11. 
    
12.     i = 1: j = 1
    
13.     If Right(strPath, 1) Like "[/\]" Then strPath = Left(strPath, Len(strPath) - 1)
    
14. 
    
15.     On Error Resume Next
    
16. 
    
17.     strDstFolder = strPath & Application.PathSeparator & strSubFolder & Application.PathSeparator
    
18.     MkDir strDstFolder
    
19. 
    
20.     On Error GoTo ErrorHandler
    
21.     ReDim arrPath(1 To 1)
    
22. 
    
23.     arrPath(i) = strPath & Application.PathSeparator
    
24. 
    
25.     sPath = arrPath(j)
    
26. 
    
27.     Debug.Print sPath
    
28. 
    
29.     Do While Len(sPath)
    
30.         strFileName = Dir(sPath & "*.*", vbDirectory + vbNormal)
    
31.         Do While Len(strFileName)
    
32. 
    
33.             If Not (strFileName = "." Or strFileName = "..") Then
    
34.                 If (GetAttr(sPath & "" & strFileName) And vbDirectory) = 16 Then
    
35.                     '避免读取错误
    
36.                     If Err.Number <> 0 Then Err.Clear: GoTo End1If
    
37.                     If strFileName <> strDstFolder Then
    
38.                         i = i + 1
    
39.                         ReDim Preserve arrPath(1 To i)
    
40.                         arrPath(i) = sPath & strFileName & Application.PathSeparator
    
41.                     End If
    
42.                 Else
    
43.                     If UCase(strFileName) Like UCase(strMatch) Then
    
44.                         Name sPath & strFileName As strDstFolder & strFileName
    
45.                     End If
    
46. 
    
47.                 End If
    
48.             End If
    
49. End1If:
    
50.             strFileName = Dir
    
51.         Loop
    
52. 
    
53.         j = j + 1
    
54.         If j > i Then Exit Do
    
55.         sPath = arrPath(j)
    
56.     Loop
    
57. 
    
58. ErrorHandler:
    
59.     MsgBox Err.Number & vbCrLf & _
    
60.            Err.Description
    
61.     Resume Next
    
62. 
    
63. End Sub
    
64. 
    

复制代码

yl.fu

hwc2ycy 发表于 2013-5-25 12:32
Call ListDirs([d2].Value, "*.bmp")
改为
    Call ListDirs([d2].Value, "*.nc")

這次是要移動該文件的當前資料夾，謝謝老師

hwc2ycy

If strFileName <> strDstFolder Then
这一句有BUG，
应该写成
If sPath & strFileName & Application.PathSeparator <> strDstFolder Then
有可能还要考虑大小写的情况。

yl.fu

不知這個是否和我這個移動資料夾有關，我是看不懂啊5555555555
Public Function ListFile(MuLu As String, Zi As Boolean, Optional LeiXing As String = "")
    Dim MyFile As String, ms As String
    Dim arr, brr, x
    Dim i As Integer
    Set d = CreateObject("Scripting.Dictionary")
    If Right(MuLu, 1) <> "\" Then MuLu = MuLu & "\"
    d.Add MuLu, ""
    i = 0
   
    On Error Resume Next '这里增加错误时继续的处理代码
    Do While i < d.Count
        brr = d.keys
        MyFile = Dir(brr(i), vbDirectory)
        Do While MyFile <> ""
            If MyFile <> "." And MyFile <> ".." Then
                If (GetAttr(brr(i) & MyFile) And vbDirectory) = vbDirectory Then
                    If Err.Number Then '这里增加文件名字符错误处理判断
                        Err.Clear '#52 文件名错误
                    Else
                        d.Add (brr(i) & MyFile & "\"), ""
                    End If
                End If
            End If
            MyFile = Dir
        Loop
        If Zi = False Then Exit Do
        i = i + 1
    Loop
    If LeiXing = "" Then
        ListFile = Application.Transpose(d.keys)
    Else
        For Each x In d.keys
            MyFile = Dir(x & LeiXing)
            Do While MyFile <> ""
                ms = ms & x & MyFile & ","
                MyFile = Dir
            Loop
            If Zi = False Then Exit For
        Next
        If ms = "" Then ms = "没有符合要求的文件,"
        ListFile = Application.Transpose(Split(ms, ","))
    End If
End Function

yl.fu

用FSO方法遍历指定路径下所有文件夹，查找文件名中含某个字符的文件。


Dim s$, fNm$ '定义公共变量：关键词s和文件名结果fNm



Sub FindFile()

    s = InputBox("Input key word:", "Find Files", s) '输入要查找的文件名中的关键词

    If s = "" Then Exit Sub

    pth = InputBox("Confirm FileFolder Path:", "Find Files", ThisWorkbook.Path) '输入路径

   

    fNm = "": tms = Timer '文件名结果fNm变量的初始化

    Call FindFileName(pth) '调用递归过程

    MsgBox Format(Timer - tms, "0.000s ")

'    Workbooks.Open filename:=fNm '打开这个文件或做其它事

   

End Sub



Sub FindFileName(pth)

    If fNm <> "" Then Exit Sub '找到以后就结束递归过程（如果要找到全部则这一句注释掉）

   

    Set fso = CreateObject("Scripting.FileSystemObject") '设置fso对象

    Set fld = fso.GetFolder(pth) '设置fso对象的父文件夹fld

    Set fsb = fld.SubFolders '设置fso对象文件夹下的子文件夹fsb

    For Each fd In fsb '遍历所有子文件夹

        For Each f In fd.Files '遍历每个子文件夹中的所有文件

            If InStr(f.Name, s) Then fNm = fd.Path & "\" & f.Name: Exit Sub

            '找到符合关键词的文件后退出（或者可以存入数组内然后继续查找所有符合的文件）

        Next

        Call FindFileName(fd.Path) '该子文件夹遍历结束时，继续递归进入该文件夹的子文件夹搜寻……

    Next

End Sub

普通浏览复制代码保存代码打印代码
Dim s$, fNm$ '定义公共变量：关键词s和文件名结果fNm

Sub FindFile()
    s = InputBox("Input key word:", "Find Files", s) '输入要查找的文件名中的关键词
    If s = "" Then Exit Sub
    pth = InputBox("Confirm FileFolder Path:", "Find Files", ThisWorkbook.Path) '输入路径
   
    fNm = "": tms = Timer '文件名结果fNm变量的初始化
    Call FindFileName(pth) '调用递归过程
    MsgBox Format(Timer - tms, "0.000s ")
'    Workbooks.Open filename:=fNm '打开这个文件或做其它事
   
End Sub

Sub FindFileName(pth)
    If fNm <> "" Then Exit Sub '找到以后就结束递归过程（如果要找到全部则这一句注释掉）
   
    Set fso = CreateObject("Scripting.FileSystemObject") '设置fso对象
    Set fld = fso.GetFolder(pth) '设置fso对象的父文件夹fld
    Set fsb = fld.SubFolders '设置fso对象文件夹下的子文件夹fsb
    For Each fd In fsb '遍历所有子文件夹
        For Each f In fd.Files '遍历每个子文件夹中的所有文件
            If InStr(f.Name, s) Then fNm = fd.Path & "\" & f.Name: Exit Sub
            '找到符合关键词的文件后退出（或者可以存入数组内然后继续查找所有符合的文件）
        Next
        Call FindFileName(fd.Path) '该子文件夹遍历结束时，继续递归进入该文件夹的子文件夹搜寻……
    Next
End Sub

yl.fu

Public flist$(65535, 3), fc&, fs&, k&, s$

Sub FileList()
   
    s = InputBox("Please input File's Ext type:", "Find Files", "xl")
    If s = "" Then Exit Sub Else s = LCase(s) & "*"
    pth = InputBox("Confirm FileFolder Path:", "Find Files", ThisWorkbook.Path)
   
    k = 0: fc = 0: fs = 0: tms = Timer
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder(pth)
    t = 0
    For Each f In fld.Files
        n = InStrRev(f.Name, ".")
        If n Then
            x = LCase(Mid(f.Name, n + 1))
            If x Like s Then
                t = 1
                flist(k, 0) = x
                flist(k, 1) = f.Name
                flist(k, 2) = fld.Name
                flist(k, 3) = fld.Path
                k = k + 1
            End If
        End If
    Next
    If t Then fs = fs + 1
    fc = fc + 1
    Call GetFolderFile(pth)
   
    [a1].CurrentRegion.Offset(1) = ""
    If k Then [a2].Resize(k, 4) = flist
    [b1] = "Check " & fc & " SubFolders Get " & k & " Files from " & fs & " Folders."
    MsgBox Format(Timer - tms, "0.000s")
   
End Sub

Function GetFolderFile(pth)
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder(pth)
    Set fsb = fld.SubFolders
    For Each fd In fsb
        t = 0
        For Each f In fd.Files
            n = InStrRev(f.Name, ".")
            If n Then
                x = LCase(Mid(f.Name, n + 1))
                If x Like s Then
                    t = 1
                    flist(k, 0) = x
                    flist(k, 1) = f.Name
                    flist(k, 2) = fd.Name
                    flist(k, 3) = fd.Path
                    k = k + 1
                End If
            End If
        Next
        If t Then fs = fs + 1
        fc = fc + 1: Call GetFolderFile(fd.Path)
    Next
End Function

yl.fu

hwc2ycy 发表于 2013-5-25 12:40
If strFileName  strDstFolder Then
这一句有BUG，
应该写成

求老大，幫忙理下頭緒，謝謝了，
今天全靠老大出手，我的工作又離結束更近了一步，感謝，好人啊

yl.fu

论坛最近要求遍历文件夹或文件夹下的文件帖子比较多，每次都要编写一样的查找的代码，把它做成函数，以后方便使用。
有的要求递归遍历所有子文件夹，正好用字典实现。

'MuLu是要查找的文件夹,如："F:\VBA\pdf\Excel2007VBA"
'LeiXing是要查找的文件类型，如：*.xls,a?*.txt等，如果省略该参数，函数实现的是查找文件夹功能
'LeiXing参数不省略时：1、Zi为true时搜索所有子文件夹下符合要求的文件。2、Zi为false时仅搜索参数MuLu下符合要求的文件
'LeiXing参数省略时：  1、Zi为true时搜索参数MuLu下所有子文件。2、Zi为false时仅搜索参数MuLu下的文件夹
'函数的返回值是一个一维数组，可视具体情况使用

Public Function ListFile(MuLu As String, Zi As Boolean, Optional LeiXing As String = "")
Dim MyFile As String, ms As String
Dim arr, brr, x
Dim i As Integer
Set d = CreateObject("Scripting.Dictionary")
If Left(MuLu, 1) <> "\" Then MuLu = MuLu & "\"
d.Add MuLu, ""
i = 0
Do While i < d.Count
    brr = d.keys
    MyFile = Dir(brr(i), vbDirectory)
    Do While MyFile <> ""
        If MyFile <> "." And MyFile <> ".." Then
            If (GetAttr(brr(i) & MyFile) And vbDirectory) = vbDirectory Then d.Add (brr(i) & MyFile & "\"), ""
        End If
        MyFile = Dir
    Loop
    If Zi = False Then Exit Do
    i = i + 1
Loop
If LeiXing = "" Then
    ListFile = Application.Transpose(d.keys)
Else
    For Each x In d.keys
        MyFile = Dir(x & LeiXing)
        Do While MyFile <> ""
            ms = ms & x & MyFile & ","
            MyFile = Dir
        Loop
        If Zi = False Then Exit For
    Next
    If ms = "" Then ms = "没有符合要求的文件,"
    ListFile = Application.Transpose(Split(ms, ","))
End If
End Function
测试函数：
Public Sub a()
Dim a
a = ListFile("F:\VBA\pdf\Excel2007VBA", True, "*.xls")
Range("a1").Resize(UBound(a), 1) = a
End Sub