improving efficiency of a macro (eliminate worksheetfunctions)

[P1R]

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:

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

 

[AlphaFrog]

To replace the .TEXT function, use the VBA Format function...

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.

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.

 

[P1R]

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