improving efficiency of a macro (eliminate worksheetfunctions)

P1R

New Member
Joined
Jun 17, 2010
Messages
4
Hi all,

I'm hoping somebody out there can help me with this.
I currently have a macro that loops through a series of cells and populates them off a table stored in another sheet. The segment of the current code is below:

Code:
On Error Resume Next
Dim lookup_val As String
 
    For x = 12 To 36 Step 4
        For Y = 17 To Names("NO_STAFF").RefersToRange.Value + 16
            If .Cells(Y, 2) <> "" Then
                lookup_val = .Cells(Y, 2) & WorksheetFunction.Text(.Cells(14, x), "0")
                .Cells(Y, x) = WorksheetFunction.VLookup(lookup_val, Worksheets("ROSTER_DROP").Range("RSTR_DROP"), 4, False) 'populate the start time
                .Cells(Y, x + 1) = WorksheetFunction.VLookup(lookup_val, Worksheets("ROSTER_DROP").Range("RSTR_DROP"), 5, False) 'populate the finish time
                .Cells(Y, x + 2) = WorksheetFunction.VLookup(lookup_val, Worksheets("ROSTER_DROP").Range("RSTR_DROP"), 6, False) 'populate the shift role
                Worksheets("ROSTER_DROP").Rows(WorksheetFunction.Match(lookup_val, Worksheets("ROSTER_DROP").Range("RSTR_CONCAT"), 0) + 2).EntireRow.Delete 'delete the row in the availability drop in order to avoid double ups
            End If
        Next Y
    Next x

This code works and does populate the cells correctly, but due to the fact that it relies on a series of extremely inefficient functions (If the code doesn't find an entry it relies on the On Error Resume Next code to continue, it uses 4 seperate worksheetfunctions in order to locate, populate and remove the entry from the table) it is quite slow to load. This has caused a great deal of criticism from end users who are executing this code multiple times.

Can someone suggest a possible way in which i could improve this code (preferrably a way to eliminate the reliance on worksheetfunctions and the On Error Resume Next code)

thanks in advance
 

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.

AlphaFrog

MrExcel MVP
Joined
Sep 2, 2009
Messages
16,406
To replace the .TEXT function, use the VBA Format function...
Code:
lookup_val = .Cells(Y, 2) & Format(.Cells(14, x), "0")

To replace the VLOOKUP and MATCH functions, use the .Find method in VBA. YOU would have to define .Range("RSTR_DROP") as one column of cells and the .Find within that column. Then use .Offset

If .Range("RSTR_DROP") was just the First column of cells, you code might look something like this.
Code:
Sub Macro1()

    Dim lookup_val As String
    Dim Found As Range
    Dim rngRD As Range, rngRC As Range
    
    Set rngRD = Worksheet("RSTR_DROP").Range("[COLOR="Red"]A1:A10[/COLOR]")     'First column of "RSTR_DROP"
    Set rngRC = Worksheet("RSTR_DROP").Range("[COLOR="Red"]B1:B10[/COLOR]")     'First column of "RSTR_CONCAT"
    
    Application.ScreenUpdating = False
     
        For x = 12 To 36 Step 4
            For Y = 17 To Names("NO_STAFF").RefersToRange.Value + 16
                If Not IsEmpty(Cells(Y, 2)) Then
                
                    lookup_val = Cells(Y, 2) & Format(Cells(14, x), "0")
                    
                    Set Found = Nothing
                    Set Found = rngRD.Find(What:=lookupval, _
                                LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                                SearchDirection:=xlNext, MatchCase:=False)
                    If Not Found Is Nothing Then
                        .Cells(Y, x).Resize(, 3).Value = Found.Offset(0, 3).Resize(, 3).Value
                    End If
                        
                    Set Found = Nothing
                    Set Found = rngRC.Find(lookupval)
                    If Not Found Is Nothing Then
                        Found.Offset(2, 0).EntireRow.Delete     'delete the row in the availability drop in order to avoid double ups
                    End If
                    
                End If
            Next Y
        Next x

    Application.ScreenUpdating = True
    
End Sub

This isn't tested, but maybe you'll get ideas on how it could be done.
 
Last edited:

P1R

New Member
Joined
Jun 17, 2010
Messages
4
Hi AlphaFrog,

thanks for that advice, its exactly what i was looking for. Only a couple of small tweeks to make it work, i will put that in now.

thanks again for your help
 

Watch MrExcel Video

Forum statistics

Threads
1,130,346
Messages
5,641,598
Members
417,225
Latest member
LukiiMaxim96

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top