1

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

结束子

4

1 回答 1

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 文件的路径。

于 2013-06-11T09:31:38.903 回答