使用VBA循环提高效率

时间：2016-06-08 08:37:17

标签： excel vba loops

我是这个网站的新手。我没有编码技能，但我决定解决Excel VBA，因为我想让我的工作流程更加自动化。这是我的问题。我用我从网上挖出的东西制作了我的宏（对不起，我无法为创作者添加适当的功劳）。它整合了40个文件中的信息。这40个文件具有相同的基本布局但信息不同。我需要做的是将几个不同的范围复制到一个工作表。我已经有了它的工作，但我很确定它的做法很艰难。

My worksheet I pull data from

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

基本上我用循环打开每个文件总共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

2 个答案:

答案 0 :(得分：0)

尝试避免选择。

除非您想要查看复制的实际数据。但它真的很难看，因为它只会眨眼：）

所以而不是

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的部分。

因为它必须是目标位置，但您正在使用代码选择工作表（＆＃34; test＆＃34;）。

这意味着您要么在其他代码中选择了单元格，要么只记录了宏...我不知道......

我只是放置了Range（＆＃34; A1＆＃34;），您可以稍后更改

此外，如果您有很多公式，最好通过

关闭计算 
Application.Calculation = xlCalculationManual

因为只要有变化，excel会尝试计算每个公式，

如果没有计算，它会更快。直到你完成。

在循环结束时，请确保添加

Application.Calculation = xlCalculationAutomatic

重新开启计算。

我想补充的另一件事是

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

复制完所有内容后，

并关闭40个文件，而不仅仅是一次。

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

答案 1 :(得分：0)

首先非常感谢@ 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
相关问题
最新问题