Question

我需要一个新流程来满足我的需求。在文件中有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

Answer 1

通过在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数组 - 第一个元素可能是名称;第二个是列号，然后用它来循环。

代码运行速度极慢，无法对250行进行排序和复制

1 个答案: