Question

我有一个空白的母版纸（C：\ path1 \ path2 \ overdue.xlsm）列标题和宏按钮
-从其他工作簿中提取的数据将从第2行开始
-宏需要打开一个excel文件（C：\ path1 \ path2 \ path3 \ project1.xlsx）
-检查2个文本条件 --a“ Y”（静态单元格B7） --要检查的4个以上单元格的“过期”（单元格的范围始终以B16开头）
-如果两个条件都匹配，它将复制工作表中的各个单元格
-它需要粘贴复制的单元格，但需要转置到母版页的下一个可用行中（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。

VBA组合代码循环功能

1 个答案: