Vba 循环浏览文件夹中的所有文件

我有两个密码。我希望第二个代码对目录中的所有文件执行第一个代码。第一个代码就像一个符咒，完全符合我的需要，这就是：

Sub STATTRANSFER()
' Transfers all STATS lines
Application.ScreenUpdating = False
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = "STATS"
Set f = Sheets(1)
Set e = Sheets("Stats")
Dim d
Dim j
Dim k
d = 1
j = 1
k = 1
Do Until IsEmpty(f.Range("A" & j))
    If f.Range("A" & j) = "STATS" Then
    e.Rows(d).Value = f.Rows(j).Value
    d = d + 1
    f.Rows(j).Delete
    Else
    j = j + 1
    End If
Loop
Application.ScreenUpdating = True
End Sub

第二个代码如下所示：

    Public Sub DataProcess()

Dim folderPath
Dim filename
Dim newfilename
Dim SavePath
Dim mySubFolder As Object
Dim mainFolder As Object
Dim WB As Workbook
Dim OrigWB As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim name1 As String
Dim name2 As String

Set OrigWB = ThisWorkbook

Set objFSO = CreateObject("Scripting.FileSystemObject")
folderPath = ActiveWorkbook.Path


Set mainFolder = objFSO.GetFolder(folderPath)


filename = Dir(folderPath & "*.csv")

Do While Len(filename) > 0
    Set WB = Workbooks.Open(folderPath & filename)
    Call STATTRANSFER

    ActiveWorkbook.Close SaveChanges:=True
    filename = Dir
Loop



For Each mySubFolder In mainFolder.SubFolders
    filename = Dir(mySubFolder.Path & "\*.csv*")
    Do While Len(filename) > 0
        Set WB = Workbooks.Open(mySubFolder.Path & "\" & filename)
        Call STATTRANSFER

        ActiveWorkbook.Close SaveChanges:=True
        filename = Dir
    Loop
Next
End Sub

第二个代码确实成功地循环了我希望它访问的所有文件夹和文档，但是它错误地执行了我的第一个代码。当我单独在一个工作表上执行第一个代码时，它会创建一个名为STATS的新工作表，然后从第一个工作表中获取列a中包含单词STATS的所有行，并将它们复制到新工作表中，然后从第一个工作表中删除STATS行

---

当我使用第二个代码运行它时，它会遍历所有文件夹，但工作方式不同。我可以看到它在我的屏幕上创建了一个名为STATS的工作表，但是当它完成后，我打开了其中一个文档，所有在A列中有统计信息的行都在第一个工作表上，统计表就不在了，所有在A列中没有统计信息的数据都消失了。因此，我不确定问题出在哪里。

保持第一个接头不变，用以下部件替换第二个接头：

Sub MM()

Dim file     As Variant
Dim files    As Variant
Dim WB       As Excel.Workbook

files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & ActiveWorkbook.Path & "\*.csv"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")

For Each file In files
    Set WB = Workbooks.Open(file)
    STATTRANSFER
    WB.Close True
    Set WB = Nothing
Next

End Sub

---

正如一句话：您的代码只在第一级子文件夹中运行。如果要遍历所有子级别文件夹，必须使用递归方法，如：

Private Sub test()
    readFileSystem ("C:\Temp\")
End Sub

Private Sub readFileSystem(ByVal pFolder As String)
    Dim oFSO As Object
    Dim oFolder As Object

    ' create FSO
    Set oFSO = CreateObject("Scripting.FileSystemObject")

    ' get start folder
    Set oFolder = oFSO.getFolder(pFolder)

    ' list folder content
    listFolderContent oFolder

    ' destroy FSO
    Set oFolder = Nothing
    Set oFSO = Nothing
End Sub

Private Sub listFolderContent(ByVal pFolder As Object)
    Dim oFile As Object
    Dim oFolder As Object

    ' go thru all sub folders
    For Each oFolder In pFolder.SubFolders
        Debug.Print oFolder.Path
        ' do the recursion to list sub folder content
        listFolderContent oFolder
    Next

    ' list all files in that directory
    For Each oFile In pFolder.Files
        Debug.Print oFile.Path
    Next

    ' destroy all objects
    Set pFolder = Nothing
    Set oFile = Nothing
    Set oFolder = Nothing
End Sub

这只是一个示例，您必须调用您的第一个过程，当然仍然正确。因此，我建议在第一个过程中添加一个参数，您可以在其中传递工作簿

---

顺便说一句：始终使用数据类型删除变量。Dim j将声明一个变量，而不是您可能想要的整数。

您将在第一个工作表中看到所有统计信息，因为您在CSV文件中添加了一个额外的工作表并保存了它。根据定义，CSV文件仅保存并显示1张图纸。 对代码的这种修改可以解决您的问题，因为它会调用自身来遍历子文件夹。 试试看。 包括您的STATTRANSFER sub

Public Sub DataProcess()

thisPath = ThisWorkbook.Path
process_folders (thisPath)

End Sub

Sub process_folders(thisPath)

Dim folderPath
Dim filename
Dim newfilename
Dim SavePath
Dim mySubFolder As Object
Dim mainFolder As Object
Dim WB As Workbook
Dim OrigWB As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim name1 As String
Dim name2 As String

Set OrigWB = ThisWorkbook

Set objFSO = CreateObject("Scripting.FileSystemObject")
folderPath = ActiveWorkbook.Path

Set mainFolder = objFSO.GetFolder(folderPath)
folderPath = ActiveWorkbook.Path
filename = Dir(folderPath & "\*.csv")

Do While Len(filename) > 0
    Set WB = Workbooks.Open(folderPath & "\" & filename)
    Call STATTRANSFER

    'save file as Excel file !!!
    ActiveWorkbook.SaveAs _
    filename:=(folderPath & "\" & filename), _
    FileFormat:=xlOpenXMLWorkbook, _
    CreateBackup:=False
    ActiveWorkbook.Close (False)

    filename = Dir

Loop

    'now with each subfolder
    For Each subfolder In mainFolder.SubFolders
        process_folders (subfolder)
    Next

End Sub

---

问题是，您只能保存一张带有一张工作表的.csv文件。现在代码看起来像这样

Sub NewDataProcess()

Dim file     As Variant
Dim files    As Variant
Dim wb       As Excel.Workbook

files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & ActiveWorkbook.Path & "\*.csv"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")

For Each file In files
    Set wb = Workbooks.Open(file)
    Call STATTRANSFER(wb)
    newfilename = Replace(file, ".csv", ".xlsm")
    wb.SaveAs filename:=newfilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    wb.Close SaveChanges:=False
    Set wb = Nothing
Next

End Sub

---

现在我需要一种方法来删除旧文件，如果有人可以帮助。我再也不想要CSV文件了

您是否尝试过用

F8

单步执行第二个宏？它可以让你一行一行地观察宏的移动，你可以帮助确定宏左转的位置。我在想（大声说）您可能希望将工作簿传递到第一个宏中，以便它知道如何使用特定工作簿？您是否尝试在文件夹中打开工作簿，然后运行STATTRANSFER？如果是这样，您需要在其中引用WB。@BruceWayne使用F8不会做任何我相信的事情，因为代码运行良好，没有任何错误errors@Nathan_Sav我相信是的，但我想我不知道还有什么其他选择，也不知道你到底想修复它。我知道它运行良好，没有错误，但看起来它做得不对。仔细检查会帮助你确定哪里出了问题。但是，是的，它不会纠正任何事情，但会帮助缩小宏停止执行预期操作的范围。这会在工作簿关闭时保存工作簿吗？谢谢，我会试试看是的，

WB.Close True

可以做到这一点-我只是没有明确说明

SaveChanges

参数，但在这种特殊情况下没有什么区别，它仍然有效，但不会在ActiveWorkbook/Thisworkbook或WB上运行第一个子项。我认为在函数1中将WB作为参数，然后引用它是安全的，因此STATTRANSFER（wbToOperateOn as excel.工作簿）会产生完全相同的问题，但是如果我在文档上单独运行STATTRANSFER宏，它就可以正常工作。所以confused@Nathan_Sav当sub使用

工作簿.Open（file）

抱歉，必须格式化代码，那么有人知道如何删除文件夹中的工作簿吗？