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

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

我不想通过简单的打开和closures工作簿来实现这一点。

我宁愿这个快速工作，即有没有其他的方法，而不是打开和closures每个文件？ 什么是最快的方法呢？ 也许有一些可能性复制没有打开文件？

我设法清除我的原始代码是：

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循环以适应任何你想做的事情。 以此为起点！ 🙂

让我知道这是怎么回事，我们可以修改你的喜好