我当前正在尝试制作要转到目录的宏,打开工作簿(当前有38个,最终总共52个),过滤两列,获取总数(重复4次),然后关闭工作簿。目前,我的应用程序大约要花7分钟才能处理当前的38个工作簿。
我怎样才能加快速度?我已经禁用了屏幕更新,事件,并且将计算方法更改为xlCalculationManual。我不知道这是否是常见的做法,但是我已经看到人们问如何在不打开工作簿的情况下访问工作簿,但是我总是提出关闭屏幕更新的建议。
当我在调试模式下运行它时,Workbooks.Open()可能最多需要10秒钟。该文件目录实际上位于公司网络上,但是访问该文件通常几乎不需要任何时间,不到5秒。
工作簿中的数据可以包含相同的点,但状态不同。我认为不可能将所有数据合并到一个工作簿中。
我将尝试使用直接单元格引用。获得一些结果后,我将更新我的帖子。
Private UNAME As String
Sub FileOpenTest()
Call UserName
Dim folderPath As String
Dim filename As String
Dim tempFile As String
Dim wb As Workbook
Dim num As Integer
Dim values(207) As Variant
Dim arryindex
Dim numStr As String
Dim v As Variant
Dim init As Integer
init = 0
num = 1
arryindex = 0
numStr = "0" & CStr(num)
'Initialize values(x) to -1
For Each v In values
values(init) = -1
init = init + 1
Next
With Excel.Application
.ScreenUpdating = False
.Calculation = Excel.xlCalculationManual
.EnableEvents = False
.DisplayAlerts = False
End With
'File path to save temp file
tempFile = "C:\Users\" & UNAME & "\Documents\TEMP.xlsm"
'Directory of weekly reports
folderPath = "path here"
'First file to open
filename = Dir(folderPath & "file here" & numStr & ".xlsm")
Do While filename <> ""
Set wb = Workbooks.Open(folderPath & filename)
'Overwrite previous "TEMP.xlsm" workbook without alert
Application.DisplayAlerts = False
'Save a temporary file with unshared attribute
wb.SaveAs filename:=tempFile, AccessMode:=xlExclusive
'operate on file
Filters values, arryindex
wb.Close False
'Reset file name
filename = Dir
'I use this loop to add the appropriate number to the end ie 01, 02, 03 etc
If num >= 9 Then
num = num + 1
If num = 33 Then
num = num + 1
End If
numStr = CStr(num)
ElseIf num < 9 Then
num = num + 1
numStr = "0" & CStr(num)
End If
filename = Dir(folderPath & "filename here" & numStr & ".xlsm")
Loop
output values
'Delete "TEMP.xlsm" file
On Error Resume Next
Kill tempFile
On Error GoTo 0
End Sub
Function Filters(ByRef values() As Variant, ByRef arryindex)
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
'filter column1
ActiveSheet.Range("B6").End(xlDown).AutoFilter Field:=2, Criteria1:=Array( _
"p1", "p2", "p3", "p4", "p5"), Operator:=xlFilterValues
'filter column2
ActiveSheet.Range("J6").End(xlDown).AutoFilter Field:=10, Criteria1:=Array( _
"s1", "d2", "s3"), Operator:=xlFilterValues
'get the total of points
values(arryindex) = TotalCount
arryindex = arryindex + 1
'filter column2 for different criteria
ActiveSheet.Range("J6").End(xlDown).AutoFilter Field:=10, Criteria1:="s"
'filter colum3 for associated form
ActiveSheet.Range("AZ6").End(xlDown).AutoFilter Field:=52, Criteria1:="<>"
'get the total of points
values(arryindex) = TotalCount
arryindex = arryindex + 1
'filter coum 3 for blank forms
ActiveSheet.Range("AZ6").End(xlDown).AutoFilter Field:=52, Criteria1:="="
'get the total of points
values(arryindex) = TotalCount
arryindex = arryindex + 1
'filter for column4 if deadline was made
ActiveSheet.Range("J6").End(xlDown).AutoFilter Field:=52
ActiveSheet.Range("J6").End(xlDown).AutoFilter Field:=10, Criteria1:=Array( _
"s1", "s2", "s3", "s4", "s5", "s6"), Operator:=xlFilterValues
ActiveSheet.Range("BC6").End(xlDown).AutoFilter Field:=55, Criteria1:=RGB(146 _
, 208, 80), Operator:=xlFilterCellColor
'get total of points
values(arryindex) = TotalCount
arryindex = arryindex + 1
End Function
Public Function TotalCount() As Integer
Dim rTable As Range, r As Range, Kount As Long
Set rTable = ActiveSheet.AutoFilter.Range
TotalCount = -1
For Each r In Intersect(Range("A:A"), rTable)
If r.EntireRow.Hidden = False Then
TotalCount = TotalCount + 1
End If
Next
End Function
Function UserName() As String
UNAME = Environ("USERNAME")
End Function
Function output(ByRef values() As Variant)
Dim index1 As Integer
Dim index2 As Integer
Dim t As Range
Dim cw As Integer
'Calendar week declariations
Dim cwstart As Integer
Dim cstart As Integer
Dim cstop As Integer
Dim data As Integer
data = 0
start = 0
cw = 37
cstart = 0
cstop = 3
ThisWorkbook.Sheets("Sheet1").Range("B6").Activate
For index1 = start To cw
For index2 = cstart To cstop
Set t = ActiveCell.Offset(rowOffset:=index1, columnOffset:=index2)
t.value = values(data)
data = data + 1
Next
Next
End Function
通常,有五个规则可以使Excel-VBA宏快速运行:
不要使用.Select
方法
不要Active*
多次使用对象,
禁用屏幕更新和自动计算,
不要使用可视化Excel方法(例如Search,Autofilter等),
最重要的是,始终使用范围数组复制而不是浏览范围中的单个单元格。
其中,您仅实现了#3。此外,您还需要重新保存工作表,从而使事情更加恶化,以至于您可以执行Visual修改方法(本例中为AutoFilter)。要使其快速运行,您需要做的是首先实现其余规则,其次,停止修改源工作表,以便您可以以只读方式打开它们。
导致您的问题和迫使所有其他不良决策的原因的核心是如何实现该Filters
功能。与其尝试使用可视化Excel功能(与编写良好的VBA相比慢)(而且修改了工作表,从而强制执行了多余的保存),还不如尝试用可视化Excel函数来完成所有操作,而是仅使用范围数组复制了工作表中所需的所有数据并使用直接的VBA代码进行计数。
这是Filters
我转换为这些原理的函数示例:
Function Filters(ByRef values() As Variant, ByRef arryindex)
On Error GoTo 0
Dim ws As Worksheet
Set ws = ActiveSheet
'find the last cell that we might care about
Dim LastCell As Range
Set LastCell = ws.Range("B6:AZ6").End(xlDown)
'capture all of the data at once with a range-array copy
Dim data() As Variant, colors() As Variant
data = ws.Range("A6", LastCell).Value
colors = ws.Range("BC6", "BC" & LastCell.Row).Interior.Color
' now scan through every row, skipping those that do not
'match the filter criteria
Dim r As Long, c As Long, v As Variant
Dim TotCnt1 As Long, TotCnt2 As Long, TotCnt3 As Long, TotCnt4 As Long
TotCnt1 = -1: TotCnt2 = -1: TotCnt3 = -1: TotCnt4 = -1
For r = 1 To UBound(data, 1)
'filter column1 (B6[2])
v = data(r, 2)
If v = "p1" Or v = "p2" Or v = "p3" Or v = "p4" Or v = "p5" Then
'filter column2 (J6[10])
v = data(r, 10)
If v = "s1" Or v = "d2" Or d = "s3" Then
'get the total of points
TotCnt1 = TotCnt1 + 1
End If
'filter column2 for different criteria
If data(r, 10) = "s" Then
'filter colum3 for associated form
If CStr(data(r, 52)) <> "" Then
'get the total of points
TotCnt2 = TotCnt2 + 1
Else
' filter coum 3 for blank forms
'get the total of points
TotCnt3 = TotCnt3 + 1
End If
End If
'filter for column4 if deadline was made
v = data(r, 10)
If v = "s1" Or v = "s2" Or v = "s3" Or v = "s4" Or v = "s5" Then
If colors(r, 1) = RGB(146, 208, 80) Then
TotCnt4 = TotCnt4 + 1
End If
End If
End If
Next r
values(arryindex) = TotCnt1
values(arryindex + 1) = TotCnt2
values(arryindex + 2) = TotCnt3
values(arryindex + 3) = TotCnt4
arryindex = arryindex + 4
End Function
请注意,由于我无法为您进行测试,也因为原始代码中的Autofilter / Range效果有很多隐含性,所以我无法确定它是否正确。您将必须这样做。
注意:如果您决定实施此操作,请告诉我们其影响(如果有)。(我尝试跟踪有效的方法和有效的方法)
本文收集自互联网,转载请注明来源。
如有侵权,请联系[email protected] 删除。
我来说两句