Code running extremely slow to sort and copy 250 rows

Question

I need a new process to accomplish my needs. In the file there are 2 tabs, Make Ready & Apartments. The code scans the "Apartments" sheet to categorize 246 units and then copies only the needed rows of data to the "Make Ready" sheet, sorting them in to the appropriate section. The "Make Ready" is broken into 4 main categorizes (Rented Not Moved IN, Available to Rent, Not Ready, Notice to Vacate) and further breaks the row between 1 & 2 bedroom. This is just a tiny piece of my program but because of how slow it runs it causes major issue with it's functionality. Currently it takes anywhere from 15 seconds - 2+ Minutes to run depending on where the function is called from (I am also lost about that since it is the exact same function). Can anyone suggest a faster method as I need to get the run time down to less than a second and I am lost.

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

Column value always would be integer. Try change long datatype to integer. That can help. — Liniel, Nov 14 '15 at 15:09
Thanks for the suggestion, I did it and it made no difference. — Hareborn, Nov 14 '15 at 15:13
Upload a sample of the workbook and share the link, it would be difficult to recreate a workbook that matches your code. I usually use "google drive" when I want to share a workbook. — Davesexcel, Nov 14 '15 at 15:24
OK here is the link. https://drive.google.com/file/d/0B4IAHTiq84vFd2NTVmRrR3g5ejQ/view?usp=sharing — Hareborn, Nov 14 '15 at 15:30
All you need to do to run the code is the start command button at the bottom of the "Make Ready" sheet. It deleted all old data and resets the form then runs the updating code. — Hareborn, Nov 14 '15 at 15:36
For 1 thing, why do you need to use `.Find` to get the row numbers 246 times? Unless I completely missed something, you aren't changing them inside the loop. — Comintern, Nov 14 '15 at 16:39
The way that the "Make Ready" is broken into the 4 main section is to measure the distance between the keys is column A. When the code finds a unit that needs to be added to the "Make Ready" it insert a row and copies the data. By inserting the row it changes the distance between the keys so the code needs to re-evaluate the distance each time to be accurate. — Hareborn, Nov 14 '15 at 16:46
@Liniel Actually, it won't help, and may even run slower. In recent versions, VBA converts all integer values to type Long, even if they're declared as type Integer. So there's no longer a performance advantage to using Integer variables; in fact, Long variables may be slightly faster because VBA does not have to convert them. See MSDN documentation regarding [The Integer Data Types](https://msdn.microsoft.com/en-us/library/office/aa164506(v=office.10).aspx), and also this [SO article](http://stackoverflow.com/questions/26409117/why-use-integer-instead-of-long) — Ron Rosenfeld, Nov 16 '15 at 01:05
@Hareborn if the row #'s only change when you add 1, then just increment the row # variable by 1 each time you insert a new row. — Grade 'Eh' Bacon, Nov 16 '15 at 15:26

Ron Rosenfeld · Accepted Answer · 2015-11-16T14:32:55.963

You should be able to speed up that routine at least five to tenfold, if not more, by doing the processing in VBA arrays rather than going back and forth to the worksheet. The back and forth, even with screenupdating and calculation turned off is still quite time consuming.

Here is an example of how to read your data into a VBA Array:

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

When you are gathering the results, again, instead of writing them, line by line to the worksheet, place them into a collection (or separate collections for each type of data); write the collections to variant arrays; then write the arrays directly to the worksheet. You can reformat them at that time also. The coding will be more complex but, again, the execution time will be much improved.

To write a variant array to a range, you merely do something like (pseudo-code)

Set destRange = Cells(x,y).Resize(ubound(vResults,1), ubound(vResults,2))
with destRange
    .Value - vResults
    .Various Formatting stuff
    .entirecolumn.autofit
end with

EDIT Here is an example of a code snippet that would look for the column that contains "Occupied", and collect all of the rows where that column contains an "X" into a collection. Examine the collection item in the Locals window, and you will see that each item is a variant array with the number elements corresponding to the number of columns, e.g: the contents of the row.

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

Note that the text comparisons in the above code are all case sensitive. If you need a case insensitive match, consider setting Option Compare Text

Also, I would use a variable for the search string, but for this example, I hard coded "Occupied". But you could, for example, set up a 2D array with the items your are looking for -- the first element could be the name; and the second the column number, then use that for your looping.

I am completely self taught and have very little knowledge of variant arrays. Is their a idiot's book that will give me an idea on how to use them? — Hareborn, Nov 14 '15 at 23:44
@Hareborn I have no books to recommend. Searching the internet may give you some leads. I would definitely start at [Chip Pearson's website](http://www.cpearson.com/Excel/Topic.aspx) which has a trove of useful information, including pages on using arrays in VBA. — Ron Rosenfeld, Nov 15 '15 at 00:17
+1 for arrays, and instead of `range.find` method (wich is really the SLOWEST), do a simple loop using arrays (speed up to 80 times for big arrays) — Patrick Lepelletier, Nov 15 '15 at 17:19
@PatrickLepelletier I would have thought that by using VBA arrays, since the .find method does not work on vba arrays, the OP would have been led to loops anyway, but thanks for making that explicit. — Ron Rosenfeld, Nov 15 '15 at 18:08
How do you search an Array to get the index of a specific value in column 1 and then pull the entire row of data associated with that column. I have found multiple sites explaining how it's done but have had no luck with it. I found Match, Find, IsInArray, LookInArray and a vast amount of others. — Hareborn, Nov 16 '15 at 14:02
@Hareborn You can use a `Loop` through the Array(1,x) to see which column contains a specific parameter. You can then store rows with that parameter in a Collection; either by storing each element in an array; and adding the array to the collection; or by using the `Index` member of the `WorksheetFunction` object, and setting the `Column` argument to zero (0). (See HELP for `WorksheetFunction.Index` for further information). I'll add some example to the code above — Ron Rosenfeld, Nov 16 '15 at 14:22
Yes the downside of using arrays is that there are fewer 'built in' functions in comparison with the functions which access the workbook. But that's the tradeoff with accessing the workbook so frequently, which is what takes so much of the calculation time. — Grade 'Eh' Bacon, Nov 16 '15 at 15:27

Code running extremely slow to sort and copy 250 rows

1 Answers1