我创建了附件。有用。我想快点！
信息：“宏”和“促销声明”工作簿以及“ csv”文件夹位于一个名为“模板”的文件夹中。
目的：为每天/每周/每月使用的流程创建模板。
输出/结果：我希望它能更快地运行，因为csv文件达到100或更大时，经过的时间呈指数增长。
我知道select activate会使速度变慢，但是我无法正确设置我的dim变量并正常工作。
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
答案 0 :(得分：1)
删除.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是此工作表的最后一行和列，则