加快运行时间在VBA excel宏与双循环 [英] Speeding up run time in VBA excel macro with double loop

查看：460
本文介绍了加快运行时间在VBA excel宏与双循环的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！

问题描述

我实际上有一些工作代码，尽管我拥有的数据量和我编写代码的方式，需要一个多小时的时间来运行，我还需要添加相当多的代码来实际分析数据。我正在使用一个双循环，在我添加了screenupdating = false之前，它似乎是嵌套在里面的循环是花了很长时间。



这是我的有：

  Sub LReview（）
 
 Dim SecX As Workbook，LipR As Workbook 
 Dim ws As Worksheet，Xws As Worksheet，Fsheet As Worksheet 
 Dim i As Long，XwsRows As Long 
 
 Path = ThisWorkbook.Path& \
 
设置LipR = ThisWorkbook 
设置SecX = Application.Workbooks.Open（Path&SecurityXtract_Mnthly.csv）
 Windows（SecurityXtract_Mnthly.CSV） 。激活
设置Xws = Sheets（SecurityXtract_Mnthly）
 
使用Xws 
 XwsRows = .Range（B& .Rows.Count）.End（xlUp）。行
结束
 
 Windows（LMacro.xlsm）。激活
 Sheets.Add.Name =资金
设置ws =表（资金 ）
 
 Windows（SecurityXtract_Mnthly.CSV）。激活
列（B：B）。选择
 Selection.Copy 
 Windows（LMacro.xlsm ）。激活
 ws.Select 
 Range（A1）。选择
 ActiveSheet.Paste 
 Application.CutCopyMode = False 
 ActiveSheet.Range（$ A $ 1：$ A $ 60000）。RemoveDuplicates列：= 1，标题：= _ 
 xlNo 
 
 Application.DisplayAlerts = False 
 Application.ScreenUpdating = False 
 
与ws 
'更改回100+ 
对于i = 2到5 
 
 
如果ws.Range（A& i）.Value<> 然后
 Sheets.Add（After：= Sheets（Worksheets.Count））。Name = ws.Range（A& i）.Value 
设置Fsheet = ActiveSheet 
范围（A1）Value =Fund：
 Range（B1）Value = Fsheet.Name 
 Range（A2）。Value =Date：
 Range （B2）Value == Xtract！R [-1] C
 
 Windows（SecurityXtract_Mnthly.CSV）。激活
行（1：1）。选择
 Selection.Copy 
 Windows（LMacro.xlsm）。激活
行（4：4）。选择
 ActiveSheet.Paste 
 Selection.Font .Bold = True 
 Application.CutCopyMode = False 
 
对于j = 2 To XwsRows 
如果Xws.Range（B& j）.Value = Fsheet.Range B1）然后
 Windows（SecurityXtract_Mnthly.CSV）。激活
 Xws.Range（B& j）。选择
 ActiveCell.EntireRow.Select 
 Selection.Copy 
 Windows（LMacro.xlsm）。激活
 Fsheet.Range（A& j + 3）.EntireRow.Select 
 Selection.PasteSpecial粘贴：= xlPasteValues，操作：= xlNone，SkipBlanks _ 
：= False，Transpose：= False 
 Application.CutCopyMode = False 
列（A：A）。选择
 Selection.SpecialCells（xlCellTypeBlanks）。选择
 Selection.EntireRow.Delete 
 
 End If 
 Next j 
 
范围（C：D，F：F，I：BB，BD：BL，BP：BR，BT：BV，BX：CD，CF：CN，CP：DI）。选择
 Selection.Delete Shift：= xlToLeft 
 
如果
 
 Cells.Select 
 Cells.EntireColumn.AutoFit 
范围（A1 ）。选择
 
 
下一步i 
结束
 
 Application.DisplayAlerts = True 
 Application.ScreenUpdating = True 
 
 
 End Sub

我也fou在另一个问题上找到这个代码，但是我不知道是否可以应用，因为我使用两个不同的工作簿。此代码：

  If Range（S1）。Offset（i）> 0.005然后
 Range（AC）。Offset（i）.Resize（1，2）.Value = Range（Z）。Offset（i）.Resize（1，2）.Value 
结束如果

替换为：

 如果Range（S& i）> 0.005然后
 Range（Z& i，AA& i）.Copy 
 Range（AC& i，AD& i）.PasteSpecial xlPasteValues 
如果

我在这里引用的代码/问题的完整链接是：
< a href =https://stackoverflow.com/questions/14126578/suggestions-on-how-to-speed-up-loop>关于如何加快循环的建议



提前感谢您提供的任何帮助：）

解决方案

查看<一个href =http://blogs.office.com/b/microsoft-excel/archive/2009/03/12/excel-vba-performance-coding-best-practices.aspx =nofollow> Excel博客



从您在代码中看到的文章中的关键摘要：


  1. 避免选择/激活对象 - 在大多数情况下，可以直接引用单元格或范围。



    例如，而不是使用

      ActiveCell.EntireRow.Select 
     Selection.Copy

    您可以使用

      ActiveCell.EntireRow.Copy


  2. 当您的代码正在运行时，关闭所有内容，除了基本要素 - 即使您的
    电子表格中没有计算量，我也注意到使用



    Application.Calculation = xlCalculationManual



    在代码开头，那么最后，将它设置回
    （例如）...



    Application.Calculation = xlCalculationAutomatic


同时查看一些其他提示和示例。希望有帮助。


I actually have some working code, although with the amount of data I have and the way I wrote the code, it takes upwards of an hour to run, and I still need to add quite a bit of code to actually analyze the data. I'm using a double loop, and before I added the screenupdating = false it seemed like the loop nested on the inside was what was taking so long.

Here's what I have:

Sub LReview()

 Dim SecX As Workbook, LipR As Workbook
 Dim ws As Worksheet, Xws As Worksheet, Fsheet As Worksheet
 Dim i As Long, XwsRows As Long

 Path = ThisWorkbook.Path & "\"

Set LipR = ThisWorkbook
Set SecX = Application.Workbooks.Open(Path & "SecurityXtract_Mnthly.csv")
Windows("SecurityXtract_Mnthly.CSV").Activate
Set Xws = Sheets("SecurityXtract_Mnthly")

With Xws
    XwsRows = .Range("B" & .Rows.Count).End(xlUp).Row
End With

Windows("LMacro.xlsm").Activate
Sheets.Add.Name = "Funds"
Set ws = Sheets("Funds")

    Windows("SecurityXtract_Mnthly.CSV").Activate
        Columns("B:B").Select
    Selection.Copy
    Windows("LMacro.xlsm").Activate
    ws.Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.Range("$A$1:$A$60000").RemoveDuplicates Columns:=1, Header:= _
        xlNo

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    With ws
        'Change back to 100+
        For i = 2 To 5


            If ws.Range("A" & i).Value <> "" Then
            Sheets.Add(After:=Sheets(Worksheets.Count)).Name = ws.Range("A" & i).Value
            Set Fsheet = ActiveSheet
            Range("A1").Value = "Fund:"
            Range("B1").Value = Fsheet.Name
            Range("A2").Value = "Date:"
            Range("B2").Value = "=Xtract!R[-1]C"

            Windows("SecurityXtract_Mnthly.CSV").Activate
            Rows("1:1").Select
            Selection.Copy
            Windows("LMacro.xlsm").Activate
            Rows("4:4").Select
            ActiveSheet.Paste
            Selection.Font.Bold = True
            Application.CutCopyMode = False

            For j = 2 To XwsRows
                If Xws.Range("B" & j).Value = Fsheet.Range("B1") Then
                    Windows("SecurityXtract_Mnthly.CSV").Activate
                    Xws.Range("B" & j).Select
                    ActiveCell.EntireRow.Select
                    Selection.Copy
                    Windows("LMacro.xlsm").Activate
                    Fsheet.Range("A" & j + 3).EntireRow.Select
                    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                    Application.CutCopyMode = False
                    Columns("A:A").Select
                    Selection.SpecialCells(xlCellTypeBlanks).Select
                    Selection.EntireRow.Delete

                End If
            Next j

            Range("C:D, F:F, I:BB, BD:BL, BP:BR, BT:BV, BX:CD, CF:CN, CP:DI").EntireColumn.Select
                    Selection.Delete Shift:=xlToLeft

            End If

                Cells.Select
                Cells.EntireColumn.AutoFit
                Range("A1").Select


        Next i
    End With

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True


 End Sub

I also found this code on another question, but I'm not sure if it can be applied since I'm using two different workbooks. This code:

 If Range("S1").Offset(i) > 0.005 Then
            Range("AC").Offset(i).Resize(1, 2).Value = Range("Z").Offset(i).Resize(1, 2).Value
    End If

Replaced this:

If Range("S" & i) > 0.005 Then
        Range("Z" & i, "AA" & i).Copy
        Range("AC" & i, "AD" & i).PasteSpecial xlPasteValues
End If

The full link of this code/question I reference here is: Suggestions on how to speed up loop

Thanks in advance for any help you can give :)

解决方案

Check out the link on the Excel Blog

Key takeaways from the article that I see in your code:

  1. Avoid Selecting / Activating Objects - In most all cases, the cells or ranges can be directly referenced.

    For Example, instead of using

    ActiveCell.EntireRow.Select
Selection.Copy

    you can use

    ActiveCell.EntireRow.Copy

  2. Turn Off Everything But the Essentials While Your Code is Running - Even if you don't have tons of calculations in your spreadsheet, I've noticed an improvement when using

    Application.Calculation = xlCalculationManual

    at the beginning of the code and then at the end, setting it back to (for example) ...

    Application.Calculation = xlCalculationAutomatic

Take a look through some of the other tips and examples as well. Hope that helps.

这篇关于加快运行时间在VBA excel宏与双循环的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！

查看全文
相关文章
Office最新文章
热门教程
热门工具
登录 关闭
扫码关注1秒登录
发送“验证码”获取 | 15天全站免登陆