Excel中整合多個工作簿

Sub LoopAllExcelFilesInFolder() 

    'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them 
    'SOURCE: www.TheSpreadsheetGuru.com 

    Dim wb As Workbook 
    Dim myPath As String 
    Dim myFile As String 
    Dim myExtension As String 
    Dim FldrPicker As FileDialog 

    'Optimize Macro Speed 
     Application.ScreenUpdating = False 
     Application.EnableEvents = False 
     Application.Calculation = xlCalculationManual 

    'Retrieve Target Folder Path From User 
     Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker) 

     With FldrPicker 
      .Title = "Select A Target Folder" 
      .AllowMultiSelect = False 
      If .Show <> -1 Then GoTo NextCode 
      myPath = .SelectedItems(1) & "\" 
     End With 

    'In Case of Cancel 
    NextCode: 
     myPath = myPath 
     If myPath = "" Then GoTo ResetSettings 

    'Target File Extension (must include wildcard "*") 
     myExtension = "*.xls*" 

    'Target Path with Ending Extention 
     myFile = Dir(myPath & myExtension) 

     'Loop through each Excel file in folder 
     Do While myFile <> "" 
     'Set variable equal to opened workbook 
      Set wb = Workbooks.Open(Filename:=myPath & myFile) 

     'Change the file that is open 
     Windows(myFile).Activate 
     Sheets("T & A").Select         'Select the Sheet 
     Range("D3").Select          'Set the Range 
     Selection.Copy           'Change the Active File Name 
     Windows("Dredger Summary Report.xlsm").Activate 
     Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _ 
      :=False, Transpose:=False 
     'The next active cell will go to the offset 
     ActiveCell.Offset(0, 1).Select 

     'Next Instruction (Barge Volume) 
     '<<<<<<<<<<<<<Instruction Starts>>>>>>>>>>>> 
     'Change the file that is open 
     Windows(myFile).Activate 
     Sheets("T & A").Select 
     Range("F130").Select 
     Selection.Copy 
     Windows("Dredger Summary Report.xlsm").Activate 


     Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _ 
      :=False, Transpose:=False 
     ActiveCell.Offset(0, 1).Select 
     '<<<<<<<<<<<<<<Instruction Ends>>>>>>>>>>>>> 


     'Next Instruction (Area) 
     '<<<<<<<<<<<<<Instruction Starts>>>>>>>>>>>> 
     'Change the file that is open 
     Windows(myFile).Activate 
     Sheets("Input").Select 
     Range("M12").Select 
     Selection.Copy 
     Windows("Dredger Summary Report.xlsm").Activate 


     Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _ 
      :=False, Transpose:=False 
     ActiveCell.Offset(0, 1).Select 
     '<<<<<<<<<<<<<<Instruction Ends>>>>>>>>>>>>> 


     'Next Instruction (Material Type) 
     '<<<<<<<<<<<<<Instruction Starts>>>>>>>>>>>> 
     'Change the file that is open 
     Windows(myFile).Activate 
     Sheets("Input").Select 
     Range("AE12").Select 
     Selection.Copy 
     Windows("Dredger Summary Report.xlsm").Activate 


     Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _ 
      :=False, Transpose:=False 
     ActiveCell.Offset(0, 1).Select 
     '<<<<<<<<<<<<<<Instruction Ends>>>>>>>>>>>>> 


     'Next Instruction (Depth Before) 
     '<<<<<<<<<<<<<Instruction Starts>>>>>>>>>>>> 
     'Change the file that is open 
     Windows(myFile).Activate 
     Sheets("Input").Select 
     Range("K12").Select 
     Selection.Copy 
     Windows("Dredger Summary Report.xlsm").Activate 


     Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _ 
      :=False, Transpose:=False 
     ActiveCell.Offset(0, 1).Select 
     '<<<<<<<<<<<<<<Instruction Ends>>>>>>>>>>>>> 


     'Next Instruction (Depth After) 
     '<<<<<<<<<<<<<Instruction Starts>>>>>>>>>>>> 
     'Change the file that is open 
     Windows(myFile).Activate 
     Sheets("Input").Select 
     Range("J12").Select 
     Selection.Copy 
     Windows("Dredger Summary Report.xlsm").Activate 


     Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _ 
      :=False, Transpose:=False 
     ActiveCell.Offset(0, 2).Select 
     '<<<<<<<<<<<<<<Instruction Ends>>>>>>>>>>>>> 


     'Next Instruction (Dredging Depth) 
     '<<<<<<<<<<<<<Instruction Starts>>>>>>>>>>>> 
     'Change the file that is open 
     Windows(myFile).Activate 
     Sheets("Input").Select 
     Range("I12").Select 
     Selection.Copy 
     Windows("Dredger Summary Report.xlsm").Activate 


     Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _ 
      :=False, Transpose:=False 
     ActiveCell.Offset(0, 1).Select 
     '<<<<<<<<<<<<<<Instruction Ends>>>>>>>>>>>>> 


     'Next Instruction (Operational Hour) 
     '<<<<<<<<<<<<<Instruction Starts>>>>>>>>>>>> 
     'Change the file that is open 
     Windows(myFile).Activate 
     Sheets("T & A").Select 
     Range("F86").Select 
     Selection.Copy 
     Windows("Dredger Summary Report.xlsm").Activate 


     Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _ 
      :=False, Transpose:=False 
     ActiveCell.Offset(0, 2).Select 
     '<<<<<<<<<<<<<<Instruction Ends>>>>>>>>>>>>> 


     'Next Instruction (Mechanical Maintenance) 
     '<<<<<<<<<<<<<Instruction Starts>>>>>>>>>>>> 
     'Change the file that is open 
     Windows(myFile).Activate 
     Sheets("T & A").Select 
     Range("F90").Select 
     Selection.Copy 
     Windows("Dredger Summary Report.xlsm").Activate 


     Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _ 
      :=False, Transpose:=False 
     ActiveCell.Offset(0, 1).Select 
     '<<<<<<<<<<<<<<Instruction Ends>>>>>>>>>>>>> 


     'Next Instruction (Shifting Anchor) 
     '<<<<<<<<<<<<<Instruction Starts>>>>>>>>>>>> 
     'Change the file that is open 
     Windows(myFile).Activate 
     Sheets("T & A").Select 
     Range("F92").Select 
     Selection.Copy 
     Windows("Dredger Summary Report.xlsm").Activate 


     Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _ 
      :=False, Transpose:=False 
     ActiveCell.Offset(1, -11).Select 
     '<<<<<<<<<<<<<<Instruction Ends>>>>>>>>>>>>> 



      'Save and Close Workbook 
      wb.Close SaveChanges:=False 

     'Get next file name 
      myFile = Dir 

     Loop 


    'Message Box when tasks are completed 
     MsgBox "Task Complete!" 

    ResetSettings: 
     'Reset Macro Optimization Settings 
     Application.EnableEvents = True 
     Application.Calculation = xlCalculationAutomatic 
     Application.ScreenUpdating = True 

End Sub

嗨，大家好，所以我設法完善我的腳本，從不同的工作簿中的某些資料。但是我經常詢問和搜索一些關於代碼的問題。Excel中整合多個工作簿

問題：如果你看看我的代碼，我每次將我的活動工作簿（這是我的目的地）名稱更改爲其他名稱，我必須在此行Windows（「Dredger Summary Report.xlsm」）下手動更改它。。啓用。無論如何編寫一個代碼，將自動拿起積極的工作簿和活動工作表，沒有我不得不改變腳本中的名字，每次我改變我的文件名？

謝謝你，感謝所有輸入

來源

2017-06-22 JK V

'的Windows（「挖泥船摘要Report.xlsm」）Activate'可以替換。 'ThisWorkbook.Activate'，如果這是包含你的宏的工作簿。 –

請使用'ThisWorkbook'而不是'Windows（「Dredger Summary Report.xlsm」）' – Maddy

正如評論指出，ThisWorkbook代表在宏運行該文件，所以你可以使用它。

同樣，你已經有wb以在循環打開每個工作簿的引用，所以你可以使用（例如）：

wb.Activate

代替

Windows(myFile).Activate

但是，你應該避免使用激活/選擇，這有利於使您的代碼更具可讀性/更濃縮。

取而代之的是一個單一的複製/粘貼：

Windows(myFile).Activate 
    Sheets("T & A").Select 
    Range("D3").Select  
    Selection.Copy   
    Windows("Dredger Summary Report.xlsm").Activate 
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _ 
       Operation:=xlNone, SkipBlanks:=False,Transpose:=False 
    ActiveCell.Offset(0, 1).Select

你可以做這樣的事情

'... 
    Dim rngDest As Range 
    Set rngDest = Selection '<<starting point for your copying 

    '... 
    'then inside your loop... 

    'copy#1 
    wb.Sheets("T & A").Range("D3").Copy   
    rngDest.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _ 
       Operation:=xlNone, SkipBlanks:=False,Transpose:=False 

    'copy#2 is offset one column over 
    wb.Sheets("T & A").Range("F130").Copy 
    rngDest.offset(0, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _ 
       Operation:=xlNone, SkipBlanks:=False,Transpose:=False 

    'etc....

來源

2017-06-22 04:47:50

Oh yea ...... ThisWorkbook .... Thanks guy，我已經讚揚了代碼，它的工作原理！！感覺很棒，這個小小的成就！欣賞所有的幫助！ –

Excel中整合多個工作簿

回答

相關問題