我已经实施了建议的更改，现在有一个工作表，它的工作时间是它的3倍。此外，它不再形成我漂亮的整洁4分段工作表，但混乱和混乱。请帮助。
Private Sub ReportMakeReady_Click()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Unload Me
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
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
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
CUporDown = .Find("Up or Down").Column
CRemodel = .Find("Remodel").Column
CMoveOutRemodel = .Find("MO / Remodel").Column
CMoveIn = .Find("Move In").Column
CStatus = .Find("Status").Column
CMaint = .Find("Maintenance").Column
CCarpet = .Find("Carpet").Column
CVynal = .Find("Linoleum").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 MR.Range("A1:A250")
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
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 250
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
Else: APValues(FRow, CFloorPlan) = "2x1"
LRow = ((MNoticeMain - MNotAvail2Bed) - 2) + MNotAvail2Bed
MR.Cells(MNoticeMain, 1).Offset(-1).EntireRow.Insert
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
Else: APValues(FRow, CFloorPlan) = "2x1"
LRow = ((MNotAvailMain - MAvail2Bed) - 2) + MAvail2Bed
MR.Cells(MNotAvailMain, 1).Offset(-1).EntireRow.Insert
End If
ElseIf APValues(FRow, CAdmin) = "" And APValues(FRow, CRNMI) = "" And APValues(FRow, CITV) = "X" _
And APValues(FRow, CTurn) = "" And APValues(FRow, CRented) = "" 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
Else: APValues(FRow, CFloorPlan) = "2x1"
LRow = ((MEndLine - MNotice2Bed) - 2) + MNotice2Bed
MR.Cells(MEndLine, 1).Offset(-1).EntireRow.Insert
End If
ElseIf APValues(FRow, CAdmin) = "" And APValues(FRow, CRNMI) = "X" 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 = ((MRented2Bed - MRented1Bed) - 2) + MRented1Bed
MR.Cells(MRented2Bed, 1).Offset(-1).EntireRow.Insert
Else: APValues(FRow, CFloorPlan) = "2x1"
LRow = ((MAvailMain - MRented2Bed) - 2) + MRented2Bed
MR.Cells(MAvailMain, 1).Offset(-1).EntireRow.Insert
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
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
End Sub
答案 0 :(得分：2)
建议1
使用代码在主循环外找到工作表“apartments”和“Make Ready”中的列。这就是39，当你可以执行一次时，你会执行249次。
建议2
嵌套你的Ifs。
例如，对于第一个如果您测试AP.Cells(FRow, CRented) = "" And AP.Cells(FRow, CRNMI) = "X" And AP.Cells(FRow, CAdmin) = "" And AP.Cells(FRow, CFloorPlan) = "1x1"。对于第二个如果您使用不同的第四个测试重复前三个测试。对于第三个如果你再次重复前三个测试并进行第三个测试。
以下将节省大量重复测试：
If AP.Cells(FRow, CRented) = "" And AP.Cells(FRow, CRNMI) = "X" And _
AP.Cells(FRow, CAdmin) = ""
If AP.Cells(FRow, CFloorPlan) = "1x1" Then
...
ElseIf AP.Cells(FRow, CFloorPlan) = "1x1 W/D"
...
ElseIf AP.Cells(FRow, CFloorPlan) = "2x1"
...
ElseIf AP.Cells(FRow, CFloorPlan) = "1x1"
ElseIf ...
第四个If重复前三个测试中的两个，这样你可以进一步减少另一个嵌套级别的测试次数。但是，您可能会通过降低清晰度来提高速度。保留这个建议，直到你尝试了其他一些，因为他们可能已经给你所有你想要的提高速度。
建议3
当您处理工作表“公寓”和“准备就绪”的第1行时，您使用Range("A1:ZA1")。你真的有那么多专栏吗？考虑：
With Worksheets("apartments")
ColAPLast = .Cells(1,Columns.Count).Emd(xlToLeft).Column
With .Range(.Cells(1, 1), .Cells(1, ColAPLast)
CUnit = .Find("Apartment").Column
...
建议4
我需要您知道工作表“公寓”的最后一栏，因为我希望您将其加载到内存中。
考虑一下：
Dim APValues as Variant
APValues = AP.Range(.Cells(1, 1), .Cells(250,ColAPLast)).Value
If APValues(FRow, CRented) ...
第二个语句将整个感兴趣的范围从工作表“apartments”加载到变体APValues中作为二维数组。第三个语句显示访问内存中单元格值的语法类似于从工作表中访问值的语法。不同之处在于从内存中访问值比从工作表中访问它要快得多。
在为工作表“Make Ready”构建新行时，您可以执行类似的操作，但这会更复杂。试试这些建议，看看他们给你的速度有什么改进。
建议5
Integer声明一个16位变量，需要在32或64位计算机上进行特殊处理。将所有Integer替换为Long s。