VBA组合代码循环功能

Posted 2023-02-25

【中文标题】VBA组合代码循环功能

【英文标题】：VBA Combine Code- Loop through function

【发布时间】：2018-07-20 12:58:08

【问题描述】：

我有一张空白的主表（C:\path1\path2\overdue.xlsm） 列标题和宏按钮 -从其他工作簿中提取的数据将从第 2 行开始 -宏需要打开一个excel文件（C:\path1\path2\path3\project1.xlsx） -检查 2 个文本标准 - -a "Y" (静态单元格 B7) - - 一个“OVERDUE”（单元格范围始终从 B16 开始）要检查的 4 个以上单元格范围 -如果它符合这两个条件，它将从工作表中复制各种单元格 -它需要粘贴复制的单元格但转置到主工作表上的下一个可用行（C:\path\path\overdue.xlsm） -然后关闭excel文件而不保存更改（C:\path1\path2\path3\project1.xlsx） - 它需要在 (C:\path1\path2) 中的所有子文件夹中循环这个宏，每个项目都有自己的文件夹，每个文件夹都有 它自己的 xlsx 文件以及其他项目文件（这就是 xlsx 文件都在不同的文件夹中）

第一个代码-用于文件检查 我在具有标题列的模板中运行此宏。返回的信息在第 2 行开始填充。它根据其他工作簿生成一个列表。此代码打开指定文件夹中的每个文件，检查某些条件，然后在满足条件时生成一个列表。然后关闭文件。如果所有文件都在同一个文件夹中，这将很有效。

Sub OVERDUEcheck()
Dim sPath As String, sName As String
Dim bk As Workbook      'opened from the folder
Dim src As Worksheet    'sheet to retrieve data from
Dim sh As Worksheet     'the sheet with the command button
Dim rw As Long          'the row to write to on sh
Dim lr As Long          'last row col A of src sheet
Dim i As Integer        'for looping rows to look at

Set sh = ActiveSheet ' I will record the value and workbook name
' in the activesheet when the macro runs

rw = 2 ' which row to write to in the activesheet
sPath = "C:\Box Sync\LocateRequests\" ' Path for file location
sName = Dir(sPath & "*.xls")

Do While sName <> "" 'Loop until filename is blank
Set bk = Workbooks.Open(sPath & sName)
Set src = bk.Worksheets(2)

With src
    If .Range("B7").Text = "Y" Then
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        For i = 16 To lr
            If .Cells(i, "B").Text = "OVERDUE" Then
                sh.Cells(rw, "A") = .Range("b5")
                sh.Cells(rw, "B") = .Range("b6")
                sh.Cells(rw, "C") = .Range("b10")
                sh.Cells(rw, "D") = .Range("b11")
                sh.Cells(rw, "E") = .Range("a" & i)
                sh.Cells(rw, "F") = .Range("B12")
                rw = rw + 1
            End If
        Next i
    End If
End With

bk.Close SaveChanges:=False
sName = Dir()

Loop ' loop until no more files

End Sub

第二个代码是我在 google 上找到的，它是通过文件夹和子文件夹循环其他函数的代码。

Public Sub openWB()    Dim FSO As Object
Dim folder As Object, subfolder As Object
Dim wb As Object

Set FSO = CreateObject("Scripting.FileSystemObject")
folderPath = "C:\Users\WYMAN\Desktop\testDel"
Set folder = FSO.GetFolder(folderPath)

With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .EnableEvents = False
    .AskToUpdateLinks = False
End With

For Each wb In folder.Files
    If Right(wb.Name, 3) = "xls" Or Right(wb.Name, 4) = "xlsx" Or 
Right(wb.Name, 4) = "xlsm" Then
        Set masterWB = Workbooks.Open(wb)
        'Modify your workbook
        ActiveWorkbook.Close True
    End If
Next
For Each subfolder In folder.SubFolders
    For Each wb In subfolder.Files
        If Right(wb.Name, 3) = "xls" Or Right(wb.Name, 4) = "xlsx" Or 
Right(wb.Name, 4) = "xlsm" Then
            Set masterWB = Workbooks.Open(wb)
            'Modify your workbook
            ActiveWorkbook.Close True
        End If
    Next
Next
With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .EnableEvents = True
    .AskToUpdateLinks = True
End With End Sub

谢谢

【问题讨论】：

如果您在代码上方给出更清晰和详细的描述，您将获得更有帮助的答案。目前有点混乱

我已经修改了我原来的帖子，希望现在更有意义。

抱歉，我没说清楚 - 修订版必须是您的第一段，因为最终结果不容易理解您要寻找的内容

嗨，我已经编辑了我的原始帖子

【参考方案1】：

我认为有最好的方法，避免重构你的代码，你的第一个函数，你可以用路径作为参数来做一个函数

Sub OVERDUEcheck(sPath As String)
Dim sName As String
Dim bk As Workbook      'opened from the folder
Dim src As Worksheet    'sheet to retrieve data from
Dim sh As Worksheet     'the sheet with the command button
Dim rw As Long          'the row to write to on sh
Dim lr As Long          'last row col A of src sheet
Dim i As Integer        'for looping rows to look at

Set sh = ActiveSheet ' I will record the value and workbook name
' in the activesheet when the macro runs

rw = 2 ' which row to write to in the activesheet
sName = Dir(sPath & "*.xls")

Do While sName <> "" 'Loop until filename is blank
Set bk = Workbooks.Open(sPath & sName)
Set src = bk.Worksheets(2)

With src
    If .Range("B7").Text = "Y" Then
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        For i = 16 To lr
            If .Cells(i, "B").Text = "OVERDUE" Then
                sh.Cells(rw, "A") = .Range("b5")
                sh.Cells(rw, "B") = .Range("b6")
                sh.Cells(rw, "C") = .Range("b10")
                sh.Cells(rw, "D") = .Range("b11")
                sh.Cells(rw, "E") = .Range("a" & i)
                sh.Cells(rw, "F") = .Range("B12")
                rw = rw + 1
            End If
        Next i
    End If
End With

bk.Close SaveChanges:=False
sName = Dir()

Loop ' loop until no more files

End Sub

然后在您的第二个代码中，将子目录发送到每个子路径：

Public Sub openWB()    Dim FSO As Object
Dim folder As Object, subfolder As Object
Dim wb As Object

Set FSO = CreateObject("Scripting.FileSystemObject")
folderPath = "C:\Users\WYMAN\Desktop\testDel"
Set folder = FSO.GetFolder(folderPath)

With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .EnableEvents = False
    .AskToUpdateLinks = False
End With

OVERDUEcheck(folderPath)

For Each subfolder In folder.SubFolders
    OVERDUEcheck(subfolder.name)
Next

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .EnableEvents = True
    .AskToUpdateLinks = True
End With End Sub

有些时候我不使用 VBA，可能会错过一些细节，但这就是想法。

制作大函数会造成很多混乱，所以我认为最好将代码与一个想法或概念分开，然后将其称为大函数，并且将来易于更改/编辑，甚至您也会更直观可以为文件创建一个函数，然后为文件夹创建一个函数。

在这种情况下，我建议您改用子程序，使用函数，例如返回 0 是否正常，否则返回 1，并在函数中使用“On Error”作为错误句柄，以了解是否有故障，记录文件夹并继续工作。

Cya。

【讨论】：

感谢 Latot，感谢您的帮助，但我无法使其正常运行。我不太擅长从头开始编写代码，我通常可以解构和重建以获得我需要的结果。这把我难住了

你好，可能因为我只写了一部分，我会用所有代码编辑消息，然后你可以测试和比较。

嗨 Latot，谢谢，更新代码，现在更有意义了。我可以运行代码，但它仍然只返回来自 folderPath 的信息而不是子文件夹我需要将代码添加到 Set subfolder = FSO，与 Set folder 行相同吗？

嗨，这是因为在代码中，您运行代码的地方，使用按钮，您为每个子文件写入相同的单元格，因此文档的值将替换为最后分析的文件，如果你想保存每个文件的数据，你需要一种组织它的方法，也许每个文件都点击一下？

嗨，有道理，有没有办法自动将从每个下一个文件中检索到的数据输入到下一个空行中？当所有文件都在同一个文件夹中时，它似乎与我的原始代码一起工作得很好。它只会从它打开的每个新文件中添加多行信息。