请教各位老师一个遍历所有文件夹下的VBA循环的问题, 谢谢!

mtsmty

在编code时发现有一个循环实现不了, Code如下:

Option Explicit

Sub BatchGetFiles_FoldersName()

Dim sfso
Dim myPath As String
Dim sh As Object
Dim Folder As Object
Dim i As Long

Application.ScreenUpdating = False

On Error Resume Next

Set sfso = CreateObject("Scripting.FileSystemObject")
Set sh = CreateObject("shell.application")
Set Folder = sh.BrowseForFolder(0, "", 0, "")

If Folder Is Nothing Then     ' Clarifying whether the user click cancel button

    Exit Sub

End If

If Not Folder Is Nothing Then      ' Clarifying whether the user select a valid path

  myPath = Folder.Items.Item.Path
  'MsgBox myPath

End If

Cells(1, 1) = "OldName"
Cells(1, 2) = "FileType"
Cells(1, 3) = "FolderPath"
Cells(1, 4) = "FileOrSubFolderPath"
Cells(1, 5) = "NewName"
Cells(1, 6) = "Filename Extension"
Cells(1, 7) = "Size (MB)"
Cells(1, 8) = "Attribute"
Cells(1, 9) = "Date Created"
Cells(1, 10) = "Last Modified"
Call GetFileName(myPath & "\")

With ActiveSheet
.Columns("A:O").AutoFit
.Range("A1:O1").Font.Bold = True
.Range("A1:O1").Font.Italic = True
.Range("A1:O1").Font.ColorIndex = 3
End With


Application.ScreenUpdating = True


End Sub

Private Sub GetFileName(myPath As String)

Dim i, j As Long
Dim arr
Dim myTxt As String
Dim objFile, objFolder
Dim fso

    Set fso = CreateObject("Scripting.FileSystemObject")

    myTxt = Dir(myPath, 31)

    i = WorksheetFunction.CountA(Range("A:A").Rows)

    Do While myTxt <> ""

    On Error Resume Next

        If myTxt <> ThisWorkbook.Name And myTxt <> "." And myTxt <> ".." And myTxt <> "081226" Then ' Clarifying the level of Folder

            i = i + 1

            Cells(i, 1) = "'" & myTxt

            If (GetAttr(myPath & myTxt) And vbDirectory) = vbDirectory Then     ' Clarifying whether the item is a Folder of File

'=============================== Folder or File =======================================================================

                Cells(i, 2) = "FileFolder"

            Else

                Cells(i, 2) = "File"

            End If

'=============================== Folder Path =======================================================================

            Cells(i, 3) = Left(myPath, Len(myPath) - 1)

'=============================== Folder or File Path =======================================================================

            Cells(i, 4) = Cells(i, 3) & "/" & Cells(i, 1)

                'Cells(i, 6) = Mid(myTxt, InStr(myTxt, "."), Len(myTxt)
            If Cells(i, 2) = "FileFolder" Then

'=============================== Folder Attributes =======================================================================

                Set objFolder = fso.getfolder(Cells(i, 4).Text)

                Cells(i, 6) = ""
                Cells(i, 7) = FormatNumber(((objFolder.Size / 1024) / 1024), -1)
                Cells(i, 8) = objFolder.Attributes
                Cells(i, 9) = objFolder.dateCreated
                Cells(i, 10) = objFolder.DateLastModified

            Else

'=============================== File Attributes =======================================================================
                Set objFile = fso.getfile(Cells(i, 4).Text)

                arr = Split(myTxt, ".")
                j = UBound(arr)

                Cells(i, 6) = "." & arr(j)
                Cells(i, 7) = FormatNumber(((objFile.Size / 1024) / 1024), -1)
                Cells(i, 8) = objFile.Attributes
                Cells(i, 9) = objFile.dateCreated
                Cells(i, 10) = objFile.DateLastModified

            End If

        End If

        myTxt = Dir

    Loop

End Sub



Sub BatchGetCurrentPathAllFolder_Subfolder_Files()
' Could find 6 subfolder
Dim i1, i2, i3, i4, i5, i6, i7 As Long
Dim myPathRng As Range
Dim PathStr, myPath As String
Dim arr, btn
Dim sh
Dim ActSh As String
Dim rec, rec1, rec2, rec3, rec4, rec5, rec6

Call BatchGetFiles_FoldersName


rec = WorksheetFunction.CountA(Range("A:A"))

Application.ScreenUpdating = False

On Error Resume Next

For i1 = 2 To rec ' Count how much Folders

        If Cells(i1, 2) = "FileFolder" Then

            myPath = Cells(i1, 4).Text        ' Get the Folder path

            Call GetFileName(myPath & "\")

        End If

Next i1

rec1 = WorksheetFunction.CountA(Range("A:A"))

For i2 = rec + 1 To rec1
    If Cells(i2, 2) = "FileFolder" Then

            myPath = Cells(i2, 4).Text        ' Get the Folder path

            Call GetFileName(myPath & "\")

        End If

Next i2

rec2 = WorksheetFunction.CountA(Range("A:A"))

For i3 = rec1 + 1 To rec2
    If Cells(i3, 2) = "FileFolder" Then

            myPath = Cells(i3, 4).Text        ' Get the Folder path

            Call GetFileName(myPath & "\")

        End If

Next i3

rec3 = WorksheetFunction.CountA(Range("A:A"))

For i4 = rec2 + 1 To rec3
    If Cells(i4, 2) = "FileFolder" Then

            myPath = Cells(i4, 4).Text        ' Get the Folder path

            Call GetFileName(myPath & "\")

        End If

Next i4

rec4 = WorksheetFunction.CountA(Range("A:A"))

For i5 = rec3 + 1 To rec4
    If Cells(i5, 2) = "FileFolder" Then

            myPath = Cells(i5, 4).Text        ' Get the Folder path

            Call GetFileName(myPath & "\")

        End If

Next i5

rec5 = WorksheetFunction.CountA(Range("A:A"))

For i6 = rec4 + 1 To rec5
    If Cells(i6, 2) = "FileFolder" Then

            myPath = Cells(i6, 4).Text        ' Get the Folder path

            Call GetFileName(myPath & "\")

        End If

Next i6

End Sub

前两个procedure 是是遍历一个路径下所有文件的路径及名称,但无法遍历子文件夹下的文件与文件夹.
第三个procedure写了六个循环可以输出六级子文件夹下的所有文件, 想要实现的循环是直到路径下所有文件夹下都没有子文件夹才停止输出, 求大神指点, 感激不尽~


附上文件:
附件.zip (22.51 KB, 下载次数: 1)

2018-6-27 07:04 上传

点击文件名下载附件

abc123281

新同学  不明白你要干什么  很简单的问题  你搞得那么复杂

abc123281

最好能上传附件  并说明想要达到的效果

sjlxp2010

Sub BatchLoop()

Dim rec1, rec2, rec3, rec4
Dim i, j, m, n

Cells(1, 1) = 1
Cells(2, 1) = 2
Cells(3, 1) = 3
Cells(4, 1) = 4
A = 1
rec1 = WorksheetFunction.CountA(Range("A:A"))

X: For i = A To rec1

    Cells(i, 1) = i

Next i

rec2 = WorksheetFunction.CountA(Range("A:A"))

For j = rec1 + 1 To rec2 + 3

    Cells(j, 1) = j

Next j

rec3 = WorksheetFunction.CountA(Range("A:A"))

For m = rec2 + 1 To rec3 + 5

    Cells(m, 1) = m

Next m

rec4 = WorksheetFunction.CountA(Range("A:A"))

For n = rec3 + 1 To rec4 + 10

    Cells(n, 1) = n

Next n
A = n
If A > 100 Then Exit Sub
GoTo X
End Sub

mtsmty

sjlxp2010 发表于 2018-6-26 19:38
Sub BatchLoop()

Dim rec1, rec2, rec3, rec4

谢谢回复~, 现在的问题是并不清楚A是多少,有一个循环会一直读取数据,我做个附件放上来您看下~

mtsmty

abc123281 发表于 2018-6-26 19:21
最好能上传附件  并说明想要达到的效果

无法上传xlsm, 我把code更新了,您看下~

zpy2

mtsmty 发表于 2018-6-26 21:24
无法上传xlsm, 我把code更新了,您看下~

压缩城zip你再上传。

mtsmty

zpy2 发表于 2018-6-27 06:44
压缩城zip你再上传。

哦哦,明白了~,谢谢

zpy2

mtsmty 发表于 2018-6-26 21:15
谢谢回复~, 现在的问题是并不清楚A是多少,有一个循环会一直读取数据,我做个附件放上来您看下~

遍历所有的文件夹可能用递归比较方便。

mtsmty

zpy2 发表于 2018-6-27 07:50
遍历所有的文件夹可能用递归比较方便。

不太会用。。。。所以才写了这么个循环，有没有什么教程呢？我搜到的都不太能实现所有子文件夹下的文件录入0.0