从多个工作簿复制范围而不打开文件

Question

我的代码是：

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Wiersz = 102
For i = 1 To Wiersz
    Workbooks.Open FileName:=Katalog & "U" & i & ".xlsx", ReadOnly:=True


    Range("D11:D210").Copy
    ThisWorkbook.Worksheets("Obliczenia").Range("E1:E200").Offset(0, i).PasteSpecial xlPasteValues


    Workbooks("U" & i & ".xlsx").Close
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True

Katalog是给定的文件路径。所有文件都命名为U1.xlsx，...，U102.xlsx 我想从每个文件中复制相同的范围。但是上面的机制非常慢，因为102个文件需要47秒。我希望这可以用于例如因此，我正在寻找一种方法来加速我的宏。

我该怎么做才能做到这一点？优选地，我将满足该代码的执行时间低于10秒。有没有可能读取一个已关闭的文件，或者可能以某种方式使用VBA数组？

总的来说，我正在寻找一种快速算法来处理大量的xlsx文件。

Answer 1

这段代码（借鉴http://www.ozgrid.com/forum/showthread.php?t=155964：

Sub GetRange() 
    With Range("A2:A20") 
        .Formula = "='C:\[Test.xlsx]Test'!D2:D20" 
        .Value = .Value 
    End With 
End Sub 

给出了如何从已关闭文件中提取范围的概念。我认为这种方法可以适应你。

这是一个可能适合你的实现。

Sub GetRangesFromClosedWorkbooks()
    Dim Source As String
    Dim Wiersz As Integer
    Dim i As Integer

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    Wiersz = 102
    For i = 1 To Wiersz
        Source = "='C:\sql\[KatalogU" & i & ".xlsx]'!D1:D210"
        ThisWorkbook.Worksheets("Obliczenia").Range("E1:E210").Offset(0, i).Select
        With Selection
            .Formula = Source
            .Value = .Value
        End With
    Next i
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub

希望有人可以告诉我们如何在不使用“选择”的情况下执行此操作，并确保在没有选择的情况下更快。

Answer 2

我并非100％确定这会适用于您的方案，但值得一试。

http://www.rondebruin.nl/win/addins/rdbmerge.htm

AddIn将允许您合并包含特定名称的文件以及每个文件的固定范围。试一试，看看你是如何相处的。

祝你好运！