Question

我将多段代码混合在一起，根据日期从文件夹中的所有工作表中提取一行数据（此部分通过消息框手动输入），然后在每个工作簿中插入一个名为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

Answer 1

如果您的代码有效，那就没关系。我认为有一些潜力可以清理它，但是如果不知道该做什么就很难。

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

这样的事情:(它只是写下而不考虑性能或任何事情）

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

你可以尝试一下。也许它有效，但无论如何你都可以看到如何获取给定文件夹中每个excel文件的路径。

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

1 个答案: