VBA组合代码循环功能

Question

• 我有一张空白的主表（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

谢谢

Answer 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。