使用VBA循环提高效率

Question

我是这个网站的新手。我没有编码技能，但我决定使用Excel VBA，因为我想让我的工作流程更加自动化。这是我的问题。我用从网上挖来的东西制作了我的宏(很抱歉，我不能给创建者添加适当的信用)。它整合了40个文件中的信息。这40个文件的基本布局相同，但信息不同。我需要做的是将几个不同的区域复制到一个工作表中。我已经完成了，但我很确定它是以艰难的方式完成的。

我的工作表我从中提取数据

我目前所做的是用一个循环将单元格A1复制到我的合并表中，打开并关闭40个文件中的每一个。然后，我用一个循环将单元格A17:G23复制到合并表中，打开并关闭40个文件中的每一个。然后，我用一个循环将单元格D5:G11复制到合并表中，该循环打开并关闭40个文件中的每一个。

基本上，我用循环打开每个文件总共7或8次。现在我把工作时间从2小时减少到了3分钟。但我认为这并没有达到应有的效率。我应该试着修复它，还是应该让它一直存在，因为它有效？

所有的循环看起来都像这样，只有不同的目标细胞可以复制和粘贴。提前谢谢。

'DECLARE AND SET VARIABLES
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim LastRow As Long
'This is the path to the files
Path = "D:work"  'Change this path
Filename = Dir(Path & "*.xls")
'Opens the files
Do While Len(Filename) > 0  'If the next file exists then
Set wbk = Workbooks.Open(Path & Filename)
'Below this is the code I use to edit each file
'Copies from the work files
Sheets("Sheet2").Select
If ActiveSheet.AutoFilterMode = True Then
ActiveSheet.AutoFilterMode = False
End If
LastRow = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row
Range("a2:aa2").Select
Selection.Copy
Windows("example.xlsx").Activate

'Chooses the tab from the consolidation file and copies the data there
Sheets("test").Select
ActiveCell.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'
ActiveCell.Offset(1, 0).Select
wbk.Close True
Filename = Dir
Loop

Answer 1

尽量避免选择。

除非您希望看到实际数据被复制。但它真的很难看到，因为它只是眨眼：)

所以不是

Sheets("Sheet2").Select
If ActiveSheet.AutoFilterMode = True Then
ActiveSheet.AutoFilterMode = False
End If
LastRow = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row
Range("a2:aa2").Select
Selection.Copy
Windows("example.xlsx").Activate

'Chooses the tab from the consolidation file and copies the data there
Sheets("test").Select
ActiveCell.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

试试这个

with Workbooks("Your source workbook").Sheets("Sheet2")
If .AutoFilterMode = True Then .AutoFilterMode = False
LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
.Range("a2:aa2").Copy Workbooks("example.xlsx").Sheets("test").Range("A1")
End With

顺便说一句，我并没有真正得到ActiveCell.Select.这个部分

因为那必须是目标位置，但您选择的是带有代码的工作表("测试")。

这意味着要么你在另一个代码上选择了单元格，要么它只是录制的宏。。。我不知道。。。

我只是放了范围("A1")，你可以稍后更改

---

此外，如果你有很多公式，最好关闭计算

Application.Calculation = xlCalculationManual

因为每当发生变化时，excel都会尝试计算每个公式，

在你完成之前，不用计算它会跑得更快。

在循环结束时，确保添加

Application.Calculation = xlCalculationAutomatic

以重新打开计算。

---

我想添加的另一件事是

打开你们提到的所有循环开始的40个文件。

并在复制完所有内容后关闭40个文件，而不仅仅是一次。

打开40个文件并保存40个文件7~8次将比打开和关闭40次花费更长的时间：)

Answer 2

首先非常感谢@Dave、@Mono和@MutjayLee的帮助。他们给我指明了我需要的方向。我找到了一种更好的循环方法，下面是我使用的整个宏。它现在只运行1个循环，而不是8个。运行时间已从约2分钟降低到约30秒。这正是我想要的。

如果有人认为这可以做得更好，请与我们分享。我很想让这变得更好。

我删除了代码中只是格式化的部分，因为这些部分只是记录在excel中，而且太长了。

Sub Consolidate_ALL()
'Created on: 11.05.2016
'by Shakdun
'Change Log:
'Date - Change made
'06.06.2016 - Added new formulas to cells A2, B2 and H2 in tab "Sheet2" that are added to each file.
'06.06.2016 - Added macro optimization. DisplayAlerts.
'08.06.2016 - Changed some comments.
'09.06.2016 - Changed the way the macro selects the source sheets and the way it copies the data from them.
'10.06.2016 - Added macro optimization. Calculation.
'15.06.2016 - Changed the way LOOPs work. Now instead of 7 or 8 loops it only has 1. Meaning it wont open each file 8 times, but only once. It copies all the information and then it makes adjustments outside of the loop. Speed increase! Run time: ~32 seconds. (run time before this update: ~2 minutes)
'16.06.2016 - Changed some comments. Changed the filtration of example2. Reviewed the code and removed redundant parts.
'16.06.2016 - Changed some formating that kept switching between the sheets several times. Now it just switches once and all formating is done a sheet at a time.
'End Of Change Log   
'Macro optimization
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Windows("example.xlsx").Activate
Sheets("test").Select
Range("A2").Select
'Declare and set variables
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim LastRow As Long
Dim r As Long, endRow As Long, pasteRowIndex As Long
'Path to source files
Path = "D:work"  'Change path here
Filename = Dir(Path & "*.xls") 'file format has to be the same as source files
'Start of loop. This opens the source files
Do While Len(Filename) > 0  
Set wbk = Workbooks.Open(Path & Filename)
Set wSheet = wbk.Worksheets("Sheet2")
Set wSheets = wbk.Worksheets("LNum")
Set wSheet1 = wbk.Worksheets("PS")
'This is what copies the data
wSheet.Range("a2:aa2").Copy
Windows("example.xlsx").Activate
Sheets("test").Select
ActiveCell.PasteSpecial Paste:=xlPasteValues
ActiveCell.Offset(1, 0).Select
wSheet.Range("a3:aa3").Copy
Windows("example.xlsx").Activate
ActiveCell.PasteSpecial Paste:=xlPasteValues
ActiveCell.Offset(1, 0).Select
wSheets.Range("C6,C7,C17").Copy
Windows("example.xlsx").Activate
ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
ActiveCell.Offset(1, 0).Select
wSheets.Range("C1").Copy
Windows("example2.xlsm").Activate
ActiveCell.PasteSpecial Paste:=xlPasteValues
ActiveCell.Offset(1, 0).Select
wSheet.Range("C14:D14").Copy
Windows("example2.xlsm").Activate
ActiveCell.PasteSpecial Paste:=xlPasteValues
ActiveCell.Offset(1, 0).Select
wSheet1.Range("D5:F11").Copy
Windows("example2.xlsm").Activate
ActiveCell.PasteSpecial Paste:=xlPasteValues
ActiveCell.Offset(7, 0).Select
wSheet1.Range("A17:G23").Copy
Windows("example2.xlsm").Activate
ActiveCell.PasteSpecial Paste:=xlPasteValues
ActiveCell.Offset(7, 0).Select
wbk.Close True
Filename = Dir
Loop
Windows("example.xlsx").Activate
Sheets("test").Select
'this creates a new first column and fills it with 1, 2, 3 patern
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A2").FormulaR1C1 = "1"
Range("A3").FormulaR1C1 = "2"
Range("A4").FormulaR1C1 = "3"
Range("A5").FormulaR1C1 = "1"
Range("A6").FormulaR1C1 = "2"
Range("A7").FormulaR1C1 = "3"
Range("A2:A7.Copy
Range("A8:A649").Select
ActiveSheet.Paste
Sheets("test2").Select
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A2").Select
Sheets("test").Select
Range("A2").Select
'This cuts a specific row and pastes it on sheet test2
endRow = 1000 'probably not the best way to get the last row but it gets the job done
pasteRowIndex = 2
For r = 1 To endRow 'Loop through sheet1 and search for your criteria
If Cells(r, Columns("A").Column).Value = "2" Then 'Found
'Cut the current row
Rows(r).Cut
'Switch to the sheet where you want to paste it & paste
Sheets("test2").Select
Rows(pasteRowIndex).Select
ActiveSheet.Paste
'Next time you find a match, it will be pasted in a new row
pasteRowIndex = pasteRowIndex + 1

'Switch back to the main sheet & continue to search for your criteria
Sheets("test").Select
End If
Next r
'This cuts a specific row and pastes it on sheet test2
endRow = 1000 
pasteRowIndex = 1
For r = 1 To endRow 
If Cells(r, Columns("A").Column).Value = "3" Then 'Found
'Copy the current row
Rows(r).Cut
'Switch the sheet
Sheets("test3").Select
Rows(pasteRowIndex).Select
ActiveSheet.Paste
'Next time you find a match, it will be pasted in a new row
pasteRowIndex = pasteRowIndex + 1
Sheets("test").Select
End If
Next r
'This deletes empty rows
ActiveSheet.UsedRange.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
Range("A1").Select
'This deletes the first row in all 3 sheets
Sheets("test").Select
Columns("A:A").Delete Shift:=xlToLeft
Sheets("test2").Select
Columns("A:A").Delete Shift:=xlToLeft
Sheets("test3").Select
Columns("A:A").Delete Shift:=xlToLeft
'Random formatting that was recorded
'More random formatting
'Moving data to appropriate places
Sheets("test3").Select
Range("A1:C10000").Copy
Sheets("test2").Select
Range("B2:D10001").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("test3").Select
Range("A1:C10000").Copy
Sheets("test").Select
Range("B2:D10001").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A2").Select
'Even more formating
Windows("example2.xlsm").Activate
Sheets("Web").Select
'this creates a new first column and fills it with 2,7 3's and 7 4's like before
'This cuts a specific row and pastes it on sheet test2 like before
'This cuts a specific row and pastes it on sheet test2 again
'This deletes empty rows
ActiveSheet.UsedRange.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
Range("A1").Select
'More formating
'Coloring cells and more formatting. Like several hundred rows of formatting code.
'Removing macro optimization
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Done!"
End Sub