102個文件從相同的範圍複製到每個工作表

我有大約102個.xlsx文件。從它的每一個我想複製相同的範圍（一列），然後粘貼到一個工作表。因此，我希望在一個工作表中相鄰的那些列。102個文件從相同的範圍複製到每個工作表

我不想通過簡單的打開和關閉工作簿來做到這一點。

我更喜歡這樣快速工作，即除打開和關閉每個文件外，是否還有其他方法？什麼是最快的方法呢？也許有一些可能性複製沒有打開文件？

我已成功地清除我的原始代碼是：

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

有誰知道如何提高我的代碼？它運行了大約一分鐘，我希望它是秒。

來源

2016-12-17 Mroweczka

利用ADODB執行SQL（一個SQL？）上的文件查詢將保存需要打開文件（在Excel中）但它似乎是一個很大的努力去。 – YowE3K

@RonRosenfeld我曾嘗試單獨打開和關閉102個文件。放慢速度。 – Mroweczka

將你的代碼粘貼到問題中，我們可能會看到是否有東西放慢速度。 – YowE3K

試試這個的修改您的要求：

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循環，以適應任何你想做的事情。以此爲起點！ :)

讓我懂得這正好和我們可以修改根據自己的喜好

來源

2016-12-17 17:27:25 user1

你介意反饋這是如何工作的嗎？ :) – user1

它工作正常。 – Mroweczka

102個文件從相同的範圍複製到每個工作表

回答

相關問題