时间戳

首页 > 解决方案 > 优化使用 Select 和 Activate 的宏

excel - 优化使用 Select 和 Activate 的宏

问题描述

我创建了附件。有用。我想让它快点！

信息：“宏”和“促销声明”工作簿以及“csv”文件夹位于名为“模板”的文件夹中。

目的：为每天/每周/每月使用的流程创建模板。

输出/结果：我希望它运行得更快，因为当 csv 文件达到 100 或更大时，经过的时间呈指数增长。

我了解 select activate 会减慢速度，但我无法正确设置昏暗变量并正常工作。

Sub Metcash_claim_import()
'Metcash Claims Import Macro

Dim SourceWB As Workbook        'Metcash Consolidate Macro File
Dim SourceShtMcr As Worksheet
Dim SourceShtFrml As Worksheet
Dim SourceShtMcrCell As Range
Dim SourceShtFrmlCell As Range
Dim DestWB As Workbook          'Metcash Consolidate Promo Claims
Dim DestPrmClm As Worksheet
Dim DestClmDet As Worksheet
Dim DestPrmClmCell As Range
Dim DestClmDetCell As Range
Dim FPath As String             'csv Folder containing raw data export
Dim fCSV As String
Dim wbCSV As Workbook
Dim wbMST As Workbook
Dim FiName As String            'saves promo claims file to new xls file
Dim FiPath As String
Dim i As Long                   'count for total files ---- not currently used
Dim k As Long           'count for total files ---- not currently used
Dim t As Integer                'count for total files ---- not currently used
Dim StartTime As Double         'time elapsed counter
Dim MinutesElapsed As String
Dim DestWBpath As String

    StartTime = Timer           'starts timer - Remember time when macro starts

    NeedForSpeed                'speeds up macro

Workbooks.Open (ThisWorkbook.path & "\Metcash Consolidate Promo Claims.xlsm")

Set DestWB = Workbooks("Metcash Consolidate Promo Claims.xlsm")
Set DestPrmClm = DestWB.Worksheets("Promo Claims")
Set DestClmDet = DestWB.Worksheets("Claim Summary")
Set DestPrmClmCell = DestPrmClm.Range("A1")                         
Set DestClmDetCell = DestPrmClm.Range("A4")

Set SourceWB = ThisWorkbook
Set SourceShtMcr = SourceWB.Sheets("Macro")
Set SourceShtFrml = SourceWB.Sheets("Formula")
Set SourceShtMcrCell = SourceShtMcr.Range("B7")
Set SourceShtFrmlCell = SourceShtFrml.Range("J20:AA21")

Call GetLastFolderName          'calls Function to get Payment number


    DestWB.Worksheets("Promo Claims").Activate
    Rows("2:" & Rows.Count).ClearContents   ' clears promo claims tab ---- This needs to change to remove rows as only clear contents
    DestWB.Worksheets("Claim Summary").Activate
    Range("A4:C10000").ClearContents        ' clears claim summary tab ---- can this be dynamic? Never more than 10,000


FPath = ThisWorkbook.path & "\csv\"                                 'path to CSV files
fCSV = Dir(FPath & "*.csv")                                         'start the CSV file listing

    On Error Resume Next


    Do While Len(fCSV) > 0

        SourceWB.Sheets("Formula").Activate
        Range("J20:AA21").Copy

        Set wbCSV = Workbooks.Open(FPath & fCSV)                    'open a CSV file
        Set wbCSV = ActiveWorkbook


            Range("J20").Select                     'Copies formulas from Macro file and pastes into csv file
            ActiveSheet.Paste
            Last_Row = Range("A" & Rows.Count).End(xlUp).Row       'finds last row in data - must be dynamic
            Range("J21:AA21").Copy Range("J22:AA" & Last_Row)
            Application.Calculation = xlCalculationAutomatic        'calc formulas
            Application.Calculation = xlCalculationManual
            Range("J21:AA" & Last_Row).Copy
            DestWB.Worksheets("Promo Claims").Activate          'pastes calc formulas in opened workbook
            Range("A1").Select                      'gets last blank cell on tab
            Selection.End(xlDown).Select
            Selection.End(xlDown).Select
            Selection.End(xlUp).Select
            ActiveCell.Offset(1, 0).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
            wbCSV.Close savechanges:=False
            fCSV = Dir                                  'ready next CSV
    Loop

Set wbCSV = Nothing


    DestWB.Worksheets("Promo Claims").Activate            'cleaning "case quantity" and "size" fields


        Columns("J:J").Select
    Selection.Replace What:="GM", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="G", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

        Columns("I:I").Select
    Selection.Replace What:="2x150", Replacement:="2x150GM", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="2x175", Replacement:="2x175GM", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="4x160", Replacement:="4x160GM", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="6x175", Replacement:="6x175GM", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False


    On Error Resume Next                'removes blank cells
    With Range("E:E")
    .Value = .Value
    .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With

    Range("A1").Select
    Columns.AutoFit             'Auto fits Columns




    SourceWB.Sheets("Macro").Activate           'copies data that user originally pasted into Macro workbook
    Range("B7").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy

    DestWB.Worksheets("Claim Summary").Activate     'data pasted into claims file
    Range("A4").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    ActiveWorkbook.RefreshAll           'used to refresh 2 pivot tables on DestWB.Worksheets("Claim Summary") worksheet

    Columns.AutoFit             'Auto fits Columns


    FiName = Range("C1")                'saves Promo Claims file as Metcash payment no. and saves in same location 
    FiPath = ThisWorkbook.path
    ActiveWorkbook.SaveAs FileName:=FiPath & "\" & FiName & ".xlsx", _
    FileFormat:=51, CreateBackup:=False

    MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")        'stops timer - Determine how many seconds code took to run

    MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation        'Msg box for elapsed time & Claims consldaited          'how can this include the total no. of csv files opened


    ResetSpeed

End Sub



Sub GetLastFolderName()

Dim LastFolder                  As String
Dim FullPath                    As String
Dim c                           As Long

FullPath = ThisWorkbook.path

c = InStrRev(FullPath, "\")
LastFolder = Right(FullPath, Len(FullPath) - c)

ThisWorkbook.Worksheets("Macro").Cells(5, 5) = LastFolder

End Sub


Sub NeedForSpeed()
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

End Sub

Sub ResetSpeed()
'Reset Macro Optimization Settings
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub

标签： excelvba

解决方案

删除.Select

您的代码的主要问题.Select是要找到几次。

要删除它们，您可以检查问题：How to Avoid using Select in Excel VBA

在很多情况下，您只需要像这样进行更改：

Columns("J:J").Select
    Selection.Replace What:="GM", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

至：

Columns("J:J").Replace What:="GM", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

删除.Activate

与.Select您可以切换的相同

SourceWB.Sheets("Formula").Activate
        Range("J20:AA21").Copy

至

SourceWB.Sheets("Formula").Range("J20:AA21").Copy

通常，如果您始终定义您的范围在哪个工作表/工作簿上，则无需激活

避免复制粘贴：

复制粘贴经常经过剪贴板，因此占用大量内存空间。在此链接中，有一些使您的代码更快的好方法，包括复制粘贴。

http://www.ozgrid.com/VBA/SpeedingUpVBACode.htm

最后一行/最后一个单元格：

在您的代码中，您主要使用 .select 来查找工作表的最后一行或最后一个单元格。如果您想在不选择 is 并向下滚动的情况下获取最后一行，您可以输入如下公式：

Dim LastRow As Long
LastRow = mainWS.Range("A" & Rows.Count).End(xlUp).Row

如果您的代码发生变化并且最后一行发生更改，您可以稍后重新输入该行以重新更新您的最后一行。如果您对最后一列执行相同操作：

Dim LastCol As Long
LastCol = mainWS.Cells(1, Columns.Count).End(xlToLeft).Column

您将获得最后一个单元格，如下所示：

cells(LastRow, LastCol)

总结一个例子：

SourceWB.Sheets("Macro").Activate           'copies data that user originally pasted into Macro workbook
Range("B7").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

DestWB.Worksheets("Claim Summary").Activate     'data pasted into claims file
Range("A4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

可能变成：

DestWB.Worksheets("Claim Summary").Range("A4").value = SourceWB.Sheets("Macro").Cells(LastRow, LastCol).value

如果您LastRow和LastCol是此工作表的最后一行和最后一列

推荐阅读