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 嗨，大家好，我已经设法完善我的脚本来从不同的工作簿中提取特定的数据。 但是，我经常询问和search一些关于代码的问题。
问题：如果你看我的代码，每次我把我的活动工作簿（这是我的目的地）名称更改为其他名称，我必须在此行Windows（“挖泥机摘要报告.xlsm”）手动更改它。 无论如何编写一个代码，将自动拿起积极的工作簿和积极的工作表，没有我必须改变脚本中的名字，每次我改变我的文件名？
谢谢你，感谢任何input
如注释中所述， ThisWorkbook表示macros在运行的文件，因此您可以使用该文件。
同样，您已经将wb作为循环中打开的每个工作簿的引用，所以您可以使用（例如）：
wb.Activate
代替
Windows(myFile).Activate
但是，您应该避免使用激活/select，这有利于使您的代码更易读/更浓缩。
而不是这一个单一的复制/粘贴：
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....