Question

我有大约102个.xlsx文件。从每个我想复制相同的范围（一列），然后粘贴到一个工作表。因此，我希望将这些列放在一个工作表中，彼此相邻。

我不想通过简单地打开和关闭工作簿来做到这一点。

我希望快速工作，除了打开和关闭每个文件之外还有其他方法吗？最快的方法是什么？也许有可能在没有打开文件的情况下进行复制？

我已设法清除原始代码：

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Wiersz = 102
For i = 1 To Wiersz
    Workbooks.Open FileName:=Kat & "U" & i & ".xlsx"
    Range("D11:D210").Copy
    ThisWorkbook.Worksheets("Obl").Range("E1:E200").Offset(0, i).PasteSpecial xlPasteValues
    Workbooks("U" & i & ".xlsx").Close
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True

有人知道如何改进我的代码吗？它运行大约一分钟，我希望它是秒。

Answer 1

尝试修改您的要求：

Sub Test()

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With

Dim StrFile As String
Dim StrPath As String
Dim icounter As Integer

'StrPath = "enter file path here\"
'StrFile = Dir("enter file path here\*.xlsx*")

For icounter = 1 To 4 'or 102 in your case
    StrPath = Left(StrPath, Len(StrPath) - 2) & icounter & "\"
    StrFile = Dir(StrPath & "*.xlsx*")
        Do While Len(StrFile) > 0
            ActiveWorkbook.Worksheets("whatever").Range("whatever").Copy 'or whatever
            Set Fldrwkbk = Workbooks.Open(StrPath & StrFile, False, False)
            Fldrwkbk.Sheets("whatever").Range("whatever").PasteSpecial Paste:=xlPasteValues
            Fldrwkbk.Close SaveChanges:=True
            StrFile = Dir
        Loop
Next icounter

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

更改Do While循环以适合您想要的任何操作。以此为起点！：）

让我知道这是怎么回事，我们可以根据自己的喜好进行修改

102个文件从每个工作表复制相同的范围

1 个答案: