我需要一个新流程来满足我的需求。在文件中有2个标签，Make Ready＆amp;公寓。该代码扫描＆＃34;公寓＆＃34;要对246个单元进行分类，然后仅将所需的数据行复制到＆＃34;准备就绪＆＃34;工作表，将它们分类到适当的部分。 ＆＃34;做好准备＆＃34;被分为4个主要类别（租用未移入，可供租用，未准备好，空出通知）并进一步打破1和1之间的行。 2间卧室。这只是我程序中的一小部分，但由于它的运行速度有多慢，因此导致其功能出现重大问题。目前它需要15秒 - 2+分钟才能运行，具体取决于调用函数的位置（我也失去了它，因为它是完全相同的函数）。任何人都可以建议更快的方法，因为我需要将运行时间缩短到不到一秒钟而且我迷路了。
Function ReportMakeReadyFill()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Dim FRow As Long
Dim LRow As Long
Dim ColAPLast1 As Long
Dim ColAPLast2 As Long
Dim APValues As Variant
Dim MRValues As Variant
Dim AP As Worksheet
Dim MR As Worksheet
Dim UnitBtnLoc As Range
Dim UnitBtnName As String
Dim CreateBtn As Object
Set AP = Worksheets("apartments")
Set MR = Worksheets("Make Ready")
Dim CRented As Long, CRemodel As Long, CAdmin As Long, CRNMI As Long, CStatus As Long, CUnit As Long, CUnit2 As Long
Dim CTurnNotes As Long, CUnitNotes As Long, CFinal As Long, CCabinets As Long, CFridge As Long, CRange As Long
Dim CAC As Long, CTub As Long, CCLean As Long, CPaint As Long, CVynal As Long, CUporDown As Long, CITV As Long
Dim CCarpet As Long, CMaint As Long, CMoveIn As Long, CFloorPlan As Long, CMoveOutRemodel As Long, CTurn As Long
Dim MRentedMain As Long, MRented1Bed As Long, MRented2Bed As Long
Dim MAvailMain As Long, MAvail1Bed As Long, MAvail2Bed As Long
Dim MNotAvailMain As Long, MNotAvail1Bed As Long, MNotAvail2Bed As Long
Dim MNoticeMain As Long, MNotice1Bed As Long, MNotice2Bed As Long, MEndLine As Long
Dim MUnit As Long, MFloorPlan As Long, MUporDown As Long, MRemodel As Long
Dim MMoveOutRemodel As Long, MMoveIn As Long, MStatus As Long, MMaint As Long
Dim MCarpet As Long, MVynal As Long, MPaint As Long, MClean As Long, MAC As Long, MFridge As Long
Dim MRange As Long, MTub As Long, MUnitNotes As Long, MTurnNotes As Long, MFinal As Long, MCabinets As Long
With Worksheets("apartments")
ColAPLast1 = .Cells(1, Columns.Count).End(xlToLeft).Column
With .Range(.Cells(1, 1), .Cells(1, ColAPLast1))
CRented = .Find("Occupied").Column
CRNMI = .Find("RNMI").Column
CAdmin = .Find("Admin").Column
CTurn = .Find("Turned").Column
CITV = .Find("ITV").Column
CFloorPlan = .Find("Floor Plan").Column
CUnit = .Find("Apartment").Column
CUnit2 = .Find("Apartment 2").Column
CUporDown = .Find("Up or Down").Column
CRemodel = .Find("Remodel").Column
CMoveOutRemodel = .Find("Turn/RM Start").Column
CMoveIn = .Find("Move In").Column
CStatus = .Find("Status").Column
CMaint = .Find("Maintenance").Column
CCarpet = .Find("Carpet").Column
CVynal = .Find("Vinyl").Column
CPaint = .Find("Painted").Column
CCLean = .Find("Clean").Column
CAC = .Find("AC").Column
CFridge = .Find("Fridge").Column
CRange = .Find("Range").Column
CTub = .Find("Tub").Column
CCabinets = .Find("Cabinets").Column
CUnitNotes = .Find("Unit Notes").Column
CFinal = .Find("Final Inspec").Column
CTurnNotes = .Find("Turn Notes").Column
End With
End With
With Worksheets("Make Ready")
ColAPLast2 = .Cells(1, Columns.Count).End(xlToLeft).Column
With .Range(.Cells(1, 1), .Cells(1, ColAPLast2))
MUnit = .Find("Unit").Column
MFloorPlan = .Find("Floor").Column
MUporDown = .Find("UpDown").Column
MRemodel = .Find("Remodel").Column
MMoveOutRemodel = .Find("Mo/Re Date").Column
MMoveIn = .Find("Move in").Column
MStatus = .Find("Status").Column
MMaint = .Find("Maint").Column
MCarpet = .Find("Carpet").Column
MVynal = .Find("Vynal").Column
MPaint = .Find("Paint").Column
MClean = .Find("Clean").Column
MAC = .Find("AC").Column
MFridge = .Find("Fridge").Column
MRange = .Find("Range").Column
MTub = .Find("Tub").Column
MCabinets = .Find("Cabinets").Column
MUnitNotes = .Find("Unit Notes").Column
MFinal = .Find("Final").Column
MTurnNotes = .Find("Turn Notes").Column
End With
End With
With Worksheets("apartments")
APValues = .Range(.Cells(1, 1), .Cells(250, ColAPLast1)).Value
End With
With Worksheets("Make Ready")
MRValues = .Range(.Cells(1, 1), .Cells(250, ColAPLast2)).Value
End With
For FRow = 2 To 247
With MR.Range("A1:A247")
MRentedMain = .Find("RentedMain").Row
MRented1Bed = .Find("Rented1Bed").Row
MRented2Bed = .Find("Rented2Bed").Row
MAvailMain = .Find("AvailableMain").Row
MAvail1Bed = .Find("Available1Bed").Row
MAvail2Bed = .Find("Available2Bed").Row
MNotAvailMain = .Find("NotAvailableMain").Row
MNotAvail1Bed = .Find("NotAvailable1Bed").Row
MNotAvail2Bed = .Find("NotAvailable2Bed").Row
MNoticeMain = .Find("NoticeMain").Row
MNotice1Bed = .Find("Notice1Bed").Row
MNotice2Bed = .Find("Notice2Bed").Row
MEndLine = .Find("EndLine").Row
End With
On Error Resume Next
If APValues(FRow, CAdmin) = "" And APValues(FRow, CRNMI) = "" And APValues(FRow, CITV) = "" _
And APValues(FRow, CTurn) = "" And APValues(FRow, CRented) = "" Then
If APValues(FRow, CFloorPlan) = "1x1 W/D" Or APValues(FRow, CFloorPlan) = "1x1" Then
LRow = ((MNotAvail2Bed - MNotAvail1Bed) - 2) + MNotAvail1Bed
MR.Cells(MNotAvail2Bed, 1).Offset(-1).EntireRow.Insert
MNotAvail1Bed = MNotAvail1Bed + 1
Else: APValues(FRow, CFloorPlan) = "2x1"
LRow = ((MNoticeMain - MNotAvail2Bed) - 2) + MNotAvail2Bed
MR.Cells(MNoticeMain, 1).Offset(-1).EntireRow.Insert
MNotAvail2Bed = MNotAvail2Bed + 1
End If
ElseIf APValues(FRow, CAdmin) = "" And APValues(FRow, CRNMI) = "" And APValues(FRow, CITV) = "" _
And APValues(FRow, CTurn) = "X" And APValues(FRow, CRented) = "" Then
If APValues(FRow, CFloorPlan) = "1x1 W/D" Or APValues(FRow, CFloorPlan) = "1x1" Then
LRow = ((MAvail2Bed - MAvail1Bed) - 2) + MAvail1Bed
MR.Cells(MAvail2Bed, 1).Offset(-1).EntireRow.Insert
MAvail1Bed = MAvail1Bed + 1
Else: APValues(FRow, CFloorPlan) = "2x1"
LRow = ((MNotAvailMain - MAvail2Bed) - 2) + MAvail2Bed
MR.Cells(MNotAvailMain, 1).Offset(-1).EntireRow.Insert
MAvail2Bed = MAvail2Bed + 1
End If
ElseIf APValues(FRow, CAdmin) = "" And APValues(FRow, CRNMI) = "" And APValues(FRow, CITV) = "X" _
And APValues(FRow, CTurn) = "" And APValues(FRow, CRented) = "X" Then
If APValues(FRow, CFloorPlan) = "1x1 W/D" Or APValues(FRow, CFloorPlan) = "1x1" Then
LRow = ((MNotice2Bed - MNotice1Bed) - 2) + MNotice1Bed
MR.Cells(MNotice2Bed, 1).Offset(-1).EntireRow.Insert
MNotice1Bed = MNotice1Bed + 1
Else: APValues(FRow, CFloorPlan) = "2x1"
LRow = ((MEndLine - MNotice2Bed) - 2) + MNotice2Bed
MR.Cells(MEndLine, 1).Offset(-1).EntireRow.Insert
MNotice2Bed = MNotice2Bed + 1
End If
ElseIf APValues(FRow, CAdmin) = "" And APValues(FRow, CRNMI) = "X" And APValues(FRow, CITV) = "" _
And APValues(FRow, CRented) = "" Then
If APValues(FRow, CFloorPlan) = "1x1 W/D" Or APValues(FRow, CFloorPlan) = "1x1" Then
LRow = ((MRented2Bed - MRented1Bed) - 2) + MRented1Bed
MR.Cells(MRented2Bed, 1).Offset(-1).EntireRow.Insert
MRented1Bed = MRented1Bed + 1
Else: APValues(FRow, CFloorPlan) = "2x1"
LRow = ((MAvailMain - MRented2Bed) - 2) + MRented2Bed
MR.Cells(MAvailMain, 1).Offset(-1).EntireRow.Insert
MRented2Bed = MRented2Bed + 1
End If
End If
If LRow = 0 Then
Else
MR.Cells(LRow, MUnit).Value = AP.Cells(FRow, CUnit).Value
MR.Cells(LRow, MFloorPlan).Value = AP.Cells(FRow, CFloorPlan).Value
MR.Cells(LRow, MUporDown).Value = AP.Cells(FRow, CUporDown).Value
MR.Cells(LRow, MRemodel).Value = AP.Cells(FRow, CRemodel).Value
MR.Cells(LRow, MMoveOutRemodel).Value = AP.Cells(FRow, CMoveOutRemodel).Value
MR.Cells(LRow, MMoveIn).Value = AP.Cells(FRow, CMoveIn).Value
MR.Cells(LRow, MStatus).Value = AP.Cells(FRow, CStatus).Value
MR.Cells(LRow, MMaint).Value = AP.Cells(FRow, CMaint).Value
MR.Cells(LRow, MCarpet).Value = AP.Cells(FRow, CCarpet).Value
MR.Cells(LRow, MVynal).Value = AP.Cells(FRow, CVynal).Value
MR.Cells(LRow, MPaint).Value = AP.Cells(FRow, CPaint).Value
MR.Cells(LRow, MClean).Value = AP.Cells(FRow, CCLean).Value
MR.Cells(LRow, MAC).Value = AP.Cells(FRow, CAC).Value
MR.Cells(LRow, MFridge).Value = AP.Cells(FRow, CFridge).Value
MR.Cells(LRow, MRange).Value = AP.Cells(FRow, CRange).Value
MR.Cells(LRow, MTub).Value = AP.Cells(FRow, CTub).Value
MR.Cells(LRow, MCabinets).Value = AP.Cells(FRow, CCabinets).Value
MR.Cells(LRow, MUnitNotes).Value = AP.Cells(FRow, CUnitNotes).Value
MR.Cells(LRow, MFinal).Value = AP.Cells(FRow, CFinal).Value
MR.Cells(LRow, MTurnNotes).Value = AP.Cells(FRow, CTurnNotes).Value
Set UnitBtnLoc = MR.Cells(LRow, MUnit)
UnitBtnName = MR.Cells(LRow, MUnit).Value
Sheets("Make Ready").Select
Set CreateBtn = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
Link:=False, DisplayAsIcon:=False, Left:=UnitBtnLoc.Left, Top:=UnitBtnLoc.Top, Width:=UnitBtnLoc.Width, Height:=UnitBtnLoc.Height)
CreateBtn.Name = "CB" & UnitBtnName
CreateBtn.Object.Caption = UnitBtnName
LRow = 0
End If
Next FRow
Worksheets("Make Ready").Activate
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Set ActiveSheet = "Make Ready"
End Function
答案 0 :(得分：0)
通过在VBA数组中进行处理而不是来回工作表，您应该能够将该例程加速至少五到十倍，如果不是更多的话。即使关闭屏幕更新和计算，来回也是非常耗时的。
以下是如何将数据读入VBA阵列的示例：
Set AP = Worksheets("apartments")
Set MR = Worksheets("Make Ready")
Dim vAP As Variant, LastRow As Long, LastCol As Long
With AP
LastRow = .Cells.Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
searchorder:=xlByRows, searchdirection:=xlPrevious).Row
LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), searchorder:=xlByColumns, _
searchdirection:=xlPrevious).Column
vAP = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With
当您收集结果时，再次将其逐行写入工作表，而不是将它们写入集合（或者为每种类型的数据分别设置集合）;将集合写入变体数组;然后将数组直接写入工作表。您也可以在那时重新格式化它们。编码会更复杂，但同样，执行时间也会大大改善。
要将变量数组写入范围，您只需执行类似（伪代码）
的操作Set destRange = Cells(x,y).Resize(ubound(vResults,1), ubound(vResults,2))
with destRange
.Value - vResults
.Various Formatting stuff
.entirecolumn.autofit
end with
修改 下面是一个代码片段的示例，该代码片段将查找包含“Occupied”的列，并将该列包含“X”的所有行收集到集合中。检查Locals窗口中的集合项，您将看到每个项都是一个变量数组，其数字元素对应于列数，例如：行的内容。
Option Explicit
Sub CollectRow()
Dim AP As Worksheet, MR As Worksheet
Set AP = Worksheets("apartments")
Set MR = Worksheets("Make Ready")
Dim I As Long, J As Long
Dim colRW As Collection
Set colRW = New Collection
Dim vAP As Variant, LastRow As Long, LastCol As Long
Dim V As Variant
With AP
LastRow = .Cells.Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
searchorder:=xlByRows, searchdirection:=xlPrevious).Row
LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), searchorder:=xlByColumns, _
searchdirection:=xlPrevious).Column
vAP = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With
'Get collection of occupied apartments
For J = 1 To UBound(vAP, 2)
If vAP(1, J) = "Occupied" Then Exit For
Next J
If J > UBound(vAP, 2) Then
MsgBox "Occupied not found"
Exit Sub
End If
For I = 2 To UBound(vAP)
If vAP(I, J) = "X" Then
colRW.Add Application.Index(vAP, I, 0)
End If
Next I
End Sub
请注意，上述代码中的文本比较都是区分大小写的。如果您需要不区分大小写的匹配项，请考虑设置Option Compare Text
另外，我会使用变量作为搜索字符串，但是对于这个例子，我硬编码了“Occupied”。但是，例如，您可以设置一个包含您正在寻找的项目的2D数组 - 第一个元素可能是名称;第二个是列号，然后用它来循环。