CODEWITHSUNDEEP
vbaloops
Shawn Phillips
Shawn Phillips

Reputation: 1

How do I speed up this process?

There are two pages with room numbers.

After updating the numbers on "Finish Schedule" column 2 (aka B) and sorting them into order, I want the routine to go to sheet "Work Page", find the matching room number and copy the finish data from columns 4-10 (aka D-J) into columns 4-10 of "Finish Schedule".

This works ok but not efficiently, its pretty slow. I know there's a better way to run that loop but its eluding me. Suggestions please?

Sub Refresh_Numbers()
    Application.ScreenUpdating = False
    Dim var As Variant, iRow As Long, iRowL As Long, bln As Boolean

   'Routine to copy finishes back from Work Page to main Finish Schedule
    Worksheets("Finish Schedule").Activate
    'Set up the count as the number of filled rows in the first column of Finish Schedule
    iRowL = Cells(Rows.Count, "B").End(xlUp).Row

    'Cycle through all the cells in that column:
    For iRow = 3 To iRowL
        'For every cell in Finish Schedule, Room Number column that is not empty, search through the
        'second column in sheet Work Page for a value that matches that cell value.
        If Not IsEmpty(Cells(iRow, "B")) Then
            bln = False
            var = Application.Match(Cells(iRow, "B").Value, Sheets("Work Page").Columns(2), 0)

        'If you find a matching value, indicate success by setting bln to true and exit the loop;
        'otherwise, continue searching until you reach the end of the Sheet.
        If Not IsError(var) Then
            bln = True
        End If

        'If you do find a matching value, copy the finishes to Finish Schedule
        'If you do not find a matching value copy a blank line of cells to Finish Schedule
        If bln = False Then
            Sheets("Work Page").Range("D205:J205").Copy
            Sheets("Finish Schedule").Cells(iRow, 4).PasteSpecial Paste:=xlPasteValues
            Else
            Sheets("Work Page").Cells((iRow) - 2, 4).Copy
            Sheets("Finish Schedule").Cells(iRow, 4).PasteSpecial Paste:=xlPasteValues
            Sheets("Work Page").Cells((iRow) - 2, 5).Copy
            Sheets("Finish Schedule").Cells(iRow, 5).PasteSpecial Paste:=xlPasteValues
            Sheets("Work Page").Cells((iRow) - 2, 6).Copy
            Sheets("Finish Schedule").Cells(iRow, 6).PasteSpecial Paste:=xlPasteValues
            Sheets("Work Page").Cells((iRow) - 2, 7).Copy
            Sheets("Finish Schedule").Cells(iRow, 7).PasteSpecial Paste:=xlPasteValues
            Sheets("Work Page").Cells((iRow) - 2, 8).Copy
            Sheets("Finish Schedule").Cells(iRow, 8).PasteSpecial Paste:=xlPasteValues
            Sheets("Work Page").Cells((iRow) - 2, 9).Copy
            Sheets("Finish Schedule").Cells(iRow, 9).PasteSpecial Paste:=xlPasteValues
            Sheets("Work Page").Cells((iRow) - 2, 10).Copy
            Sheets("Finish Schedule").Cells(iRow, 10).PasteSpecial Paste:=xlPasteValues
        End If
        End If
    Next iRow
    Application.CutCopyMode = False
    Worksheets("Finish Schedule").Range("D3").Select
    Application.ScreenUpdating = True
    MsgBox "Process Completed"
End Sub

Upvotes: 0

Views: 50

Answers (1)

K.Dᴀᴠɪs
K.Dᴀᴠɪs

Reputation: 10139

One of the largest issues in your code is the use of .Activate, .Copy, and .Paste. Also, you are copying each cell in a row one at a time as opposed to the entire row and flipping back and forth between worksheets in the process

Untested: Back up workbook

Sub Refresh_Numbers()

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    Dim wsFinish As Worksheet, wsWork As Worksheet
    With ThisWorkbook
        Set wsFinish = .Worksheets("Finish Schedule")
        Set wsWork = .Worksheets("Work Page")
    End With

    Dim iRow As Long
    With wsFinish
        For iRow = 3 To lastRow(wsFinish, "B")
            If Not wsWork.Range("B:B").Find(.Cells(iRow, "B"), LookIn:=xlValues, _
                        LookAt:=xlWhole) Is Nothing And Not IsEmpty(.Cells(iRow, "B")) Then

                .Range(.Cells(iRow - 2, 4), .Cells(iRow - 2, 10)).Value = wsWork.Range( _
                        wsWork.Cells(iRow, 4), wsWork.Cells(iRow, 10)).Value

            End If
        Next iRow
    End With

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

Function lastRow(ws As Worksheet, Optional col As Variant = 1) As Long
    With ws
        lastRow = .Cells(.Rows.Count, col).End(xlUp).Row
    End With
End Function

This could be even more efficient by writing your worksheet into an array first, perform the data value transfers to another array, and rewriting the new array to your second worksheet.

Upvotes: 2

Related Questions