102 файла копируют одинаковый диапазон от каждого до одного листа

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 Loop, чтобы удовлетворить все, что вы хотите сделать. Используйте это как исходную базу! :)

Дайте мне знать, как это идет, и мы можем изменить по своему вкусу