我目前正在尝试制作一个宏,将前往一个目录,打开一个工作簿(当前有38个,最终总数是52个),过滤两个列,获取总计(这将重复4次),然后关闭工作簿。当前,我的应用程序处理当前的38个工作簿需要约7分钟。
如何加快速度?我已经禁用了屏幕更新、事件,并将计算方法更改为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