VBA-将100个相同床单的数据刮除，这些数据具有可变的行数为单个合并纸

Question

我是VBA的自学成才的用户，但始终能够将我从本网站上的问题或类似的问题拼凑在一起，但是这个让我感到困惑，因此任何帮助很大已收到。

我已经编写了一些VBA，以从100个奇数Excel文件中刮下一个带有相同源表（存储在几个不同文件夹中）的数据中的数据，并在单独的工作簿中的单个合并表中。列的数量为常数（84），但是源表中的行计数是可变的（还包含公式，因此必须不计算包含公式返回"的行的行，我希望合并的表格从每个文件中获得所有记录，而没有空白。

我写了一些有效的东西，但速度很慢，我觉得问题是我基本上定义了每个单元格刮擦，这是我想用变量识别范围的许多记录（始终开始行（始终）5）要进行最后一行（变量）并进行一个GO并刮擦到Consol表格，而目标的唯一变量是下一个可用的行，然后移至下一个文件，但我尝试调整代码来做到这一点会出现错误。

Sub Test_Macro()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim fso, oFolder, oSubfolder, oFole, queue As Collection
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set queue = New Collection
    queue.Add fso.GetFolder("D:ExampleExample")
    '^^^ UPDATE THIS FILE PATH TO FOLDER WHERE THE RETURNED SCORECARDS ARE STORED. IF FOLDERS STORED IN MULTIPLE FOLDERS THIS SHOULD BE THE FOLDER CONTAINING SUBFOLDERS ^^^
    Do While queue.Count > 0
        Set oFolder = queue(1)
        queue.Remove 1 'dequeue
        For Each oSubfolder In oFolder.SubFolders
            queue.Add oSubfolder
        Next oSubfolder
        For Each oFile In oFolder.Files
            y = ThisWorkbook.Sheets("Consol").Cells(Rows.Count, 1).End(xlUp).Row + 1 '<<< Finds next available row after a value in consol sheet
            Set wb = Workbooks.Open(oFile.path) '<<< Sets variable to the open performance scorecard
            Set ws = wb.Sheets("Detailed Summary") '<<< Defines sheet in the open scorecard to scrape from
            wb.Unprotect "Password"
            ws.Unprotect "Password"
            wsLR = ws.Columns("B").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlValues).Row '<<< Defines the range containing data in the open scorecard
            For x = 5 To wsLR 
                ThisWorkbook.Sheets("Consol").Cells(y, 1) = ws.Cells(x, 2)
                ThisWorkbook.Sheets("Consol").Cells(y, 2) = ws.Cells(x, 3)
                ThisWorkbook.Sheets("Consol").Cells(y, 3) = ws.Cells(x, 4) 'etc. imagine going on to...
                ThisWorkbook.Sheets("Consol").Cells(y, 84) = ws.Cells(x, 85)
                y = y + 1
            Next x
            wb.Close (Saved = False)
        Next oFile
    Loop
End Sub

做同样的事情的任何帮助，但更快的事情会很棒！谢谢

Answer 1

一些评论可能有助于加速加速，假设速度降低在表格中：

请注意，以下所有内容都没有被调试，我认为您的代码作为书面作品，但速度很慢。

使用after关键字用于鲁棒性

wsLR = ws.Columns("B").Find("*", after:=ws.cells(1,2), SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlValues).Row '<<< Defines the range containing data in the open scorecard

将范围读取到VBA数组中，然后写入" Consol"工作表。类似：

Dim scraped As Variant
With ws
    scraped = .Range(.Cells(5, 2), .Cells(wsLR, 85))
End With
Dim consolRng As Range
Set consolRng = ThisWorkbook.Sheets("Consol").Cells(y, 1)
Set consolRng = consolRng.Resize(rowsize:=UBound(scraped, 1), columnsize:=UBound(scraped, 2))
consolRng = scraped

您可以通过将所有工作簿合并为单个VBA数组，然后将整个操作写入一个操作，而不是代码所隐含的多个写入（一个工作簿），可以将所有工作簿汇总到单个VBA数组中，从而进一步加快速度上面，但根据数据的大小，这可能更复杂，更容易出现内存问题。

另一个潜在的放缓是使用Filesystemobject收集所需文件的名称。可以通过炮击命令提示并使用dir命令。