Vba 如何运行特定于文件夹中多个文件的宏？_Vba

Vba 如何运行特定于文件夹中多个文件的宏？

vba

Vba 如何运行特定于文件夹中多个文件的宏？,vba,Vba,我将代码片段散列在一起，根据日期从文件夹中的所有工作表中取出一行数据（这部分是通过消息框手动输入的），然后在每个工作簿中插入一个名为summary的新选项卡，然后将数据行粘贴到其中。我可以部分做到这一点，但只有当我将宏插入每个工作簿时，它才起作用，但我需要代码是通用的，并循环遍历文件夹中所有已关闭的工作簿。我已经把我写得非常糟糕的代码放在下面，它有很多重复，但不知道如何在不弄糟它的情况下清理它，并且不能使它在封闭的工作簿中工作，任何帮助都将不胜感激。多谢各位代码如下： Sub Sheetnam

我将代码片段散列在一起，根据日期从文件夹中的所有工作表中取出一行数据（这部分是通过消息框手动输入的），然后在每个工作簿中插入一个名为summary的新选项卡，然后将数据行粘贴到其中。我可以部分做到这一点，但只有当我将宏插入每个工作簿时，它才起作用，但我需要代码是通用的，并循环遍历文件夹中所有已关闭的工作簿。我已经把我写得非常糟糕的代码放在下面，它有很多重复，但不知道如何在不弄糟它的情况下清理它，并且不能使它在封闭的工作簿中工作，任何帮助都将不胜感激。多谢各位

代码如下：

Sub SheetnamesCopyRowToSummaryTab() 'Includes All Worksheets LATEST
Set WSNew = Worksheets.Add
WSNew.Name = "Site Name"
WSNew.Move Before:=Sheets(1)
Columns(1).Insert
For i = 1 To Sheets.Count
    Cells(i, 1) = Sheets(i).Name
Next i
     ActiveSheet.Name = "Summary"
     'WSNew.Range("B1:J1").Value = Array("Month", "Period", "Actual Consumption",     "Invoice Consumption", "Consumption Variance", "Simulated Cost", "Invoice Cost", "Cost Variance", "Cumulative Cost Variance")

Dim NumSheets As Long
NumSheets = Sheets.Count
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Summary").Delete
Application.DisplayAlerts = True
On Error GoTo 0

Set WSNew = Worksheets.Add
WSNew.Name = "Summary"
WSNew.Move Before:=Sheets(1)
Dim strSeek As String
Application.ScreenUpdating = False
For i = 1 To NumSheets
Range("A" & i) = Sheets(i).Name
Next i

Application.ScreenUpdating = False
strSeek = InputBox(Prompt:="Enter the invoice period that you wish to search for.", _
    Title:="Select Invoice Period", Default:="MARCH 2013")
    For Each WS1 In ThisWorkbook.Sheets
    With WS1
        .UsedRange.AutoFilter Field:=1, Criteria1:=strSeek

        On Error Resume Next
        .AutoFilter.Range.Offset(1, 0).Resize(.Cells(.Rows.Count, "A").End(xlUp).Row, .Columns.Count) _
            .SpecialCells(xlCellTypeVisible).Copy Destination:=WSNew.Range("A" & WSNew.Cells(WSNew.Rows.Count, "B").End(xlUp).Row).Offset(1) 'Added .offset (1) this then took row from each ws but left blank rows on summary where there was no data on ws for the month
        On Error GoTo 0

        .AutoFilterMode = False
        'headers were placed here
    End With
Next WS1

Columns(1).Insert
For i = 1 To Sheets.Count
    Cells(i, 1) = Sheets(i).Name
Next i
ActiveSheet.Name = "Summary"
WSNew.Range("A1:J1").Value = Array("Site Name", "Month", "Period", "Actual Consumption", "Invoice Consumption", "Consumption Variance", "Simulated Cost", "Invoice Cost", "Cost Variance", "Cumulative Cost Variance")
Columns.AutoFit
Cells.Font.Size = 8
Range("B2:J12").Font.Bold = False
Range("A1:J1").Font.Bold = True
Range("A1:J1").Interior.Color = RGB(191, 191, 191)
Range("A1").RowHeight = 20
Range("A1:J1").HorizontalAlignment = xlCenter
Range("A1:J1").VerticalAlignment = xlCenter

End Sub

如果您的代码正常工作，则没有问题。我认为有一些潜力来清理它，但如果不知道必须做什么，那就很难了

宏始终在ActiveWorkbook和ActiveSheet上工作。因此，如果只打开文件夹中的每个Excel文件，调用宏并关闭（刚刚打开的）工作簿，它就可以工作

类似这样的：（只是写下来，没有考虑性能或任何东西）

通过ExcelFiles（）的公共子循环
将fso设置为对象，将wb设置为工作簿
Dim o作为对象，pathToFolder作为字符串
pathToFolder=“N:\”如果代码正常工作，就可以了。我认为有一些潜力来清理它，但如果不知道必须做什么，那就很难了
宏始终在ActiveWorkbook和ActiveSheet上工作。因此，如果只打开文件夹中的每个Excel文件，调用宏并关闭（刚刚打开的）工作簿，它就可以工作
类似这样的：（只是写下来，没有考虑性能或任何东西）
通过ExcelFiles（）的公共子循环
将fso设置为对象，将wb设置为工作簿
Dim o作为对象，pathToFolder作为字符串
pathToFolder=“N:\”'感谢您的快速响应，我尝试了您的代码。它打开了第一个文件，到目前为止，但在以下行中失败：.UsedRange in:对于此工作簿中的每个WS1。带有WS1.UsedRange.AutoFilter字段的工作表：=1，Criteria1:=strSeek-不确定这是为什么？谢谢，所以我们必须稍微修改一下你的宏。只是为了测试：如果设置strSeek=“2013年3月”
并注释掉输入框，是否会发生错误？（错误消息是什么？）它仍然停在.UsedRange，错误消息是“运行时错误1004.对象“工作簿”的方法“打开”失败”。它确实会打开第一个工作簿，插入摘要选项卡并将选项卡名称复制到列A中，然后在尝试复制数据行时停止，我是否可以将示例文件附加到此帖子？谢谢。我刚刚看到另一件事，那可能会导致错误。因此，请在代码中将每个“ThisWorkbook”替换为“ActiveWorkbook”。（说明：此工作簿是带有宏的工作簿，ActiveWorkbook是您可以看到的工作簿）哇，解决它太好了！非常感谢您的帮助。感谢您的快速响应，我尝试了您的代码。它打开了第一个文件并执行到目前为止，但在以下行中失败：.UsedRange in:对于此工作簿中的每个WS1。带有WS1.UsedRange.AutoFilter字段的工作表：=1，准则1:=strSeek-不确定这是为什么？谢谢，所以我们必须稍微修改一下你的宏。只是为了测试：如果设置strSeek=“2013年3月”并注释掉输入框，是否会发生错误？（错误消息是什么？）它仍然停在.UsedRange，错误消息是“运行时错误1004.对象“工作簿”的方法“打开”失败”。它确实会打开第一个工作簿，插入摘要选项卡并将选项卡名称复制到列A中，然后在尝试复制数据行时停止，我是否可以将示例文件附加到此帖子？谢谢。我刚刚看到另一件事，那可能会导致错误。因此，请在代码中将每个“ThisWorkbook”替换为“ActiveWorkbook”。（说明：此工作簿是带有宏的工作簿，ActiveWorkbook是您可以看到的工作簿）哇，解决它太好了！非常感谢你的帮助。
Public Sub LoopingThroughExcelFiles()
Dim fso As Object, wb As Workbook
Dim o As Object, pathToFolder As String
pathToFolder = "N:\" ' <-- has to be changed
Set fso = CreateObject("Scripting.FileSystemObject")
    For Each o In fso.GetFolder(pathToFolder).Files
        If InStr(o.Type, "Excel") Then
            Set wb = Workbooks.Open(o.Path)
            SheetnamesCopyRowToSummaryTab
            wb.Close
        End If
    Next
Set fso = Nothing
End Sub