Help with speeding up this code please.

[marksmith1985]

Hi there, I'm looking for some help with speeding up this code. It essentially takes up to 400 'batch numbers' and gets the location for each batch from a separate data file. Both the list of batches and location data is then dumped into a csv file for use in another program. The code does work, but when there are more than 50 or so batches the wait is pretty long, 400 takes around 5 minutes - this will take longer for the end users too and I'm testing on a laptop whilst they'll be using a networked VDI terminal. Here's the code:

Sub Create_Request()
'Declaration of variables
Dim wbNewFile As Workbook, wbCurrFile As Workbook
Dim sNewLoc As String, sNewFileName As String, sClaimNo As String, sRequestPri As String
Dim iRow As Long, iBatchQty As Long, iDupeCount As Integer, iDuplicates As Integer
Dim dRequestDate As Date
Dim rCell As Range
    
Application.ScreenUpdating = False
    
    'Check that batches have been entered for the new request
    iBatchQty = Sheets("Main").Range("F20").Value
    If iBatchQty <= 0 Then
    
        MsgBox "Please enter batches to be requested."
        Exit Sub
    
    End If
        
    'Assign values to variables
    Set wbCurrFile = ActiveWorkbook
    Sheets("Main").Activate
    sClaimNo = Range("B20").Value
    sRequestPri = Range("E20").Value
    dRequestDate = Range("C20").Value
    iDuplicates = 0
    iDupeCount = 0
    
    'Check that both a claim number and priority have been entered
    If sRequestPri = "" Or sClaimNo = "" Then
    
        MsgBox "Please enter a claim number and priority before proceeding"
        Exit Sub
        
    End If
    
    'Check for any duplicate batches and highlight cells where a duplicate if found
    For Each rCell In Range("Requested_Batches")
    
        iDupeCount = Application.WorksheetFunction.CountIf(Range("Requested_Batches"), rCell)
    
        If iDupeCount > 1 Then
            
            rCell.Value = ""
            iDuplicates = iDuplicates + 1
            
        End If
    
    Next rCell
    
    ActiveWorkbook.Worksheets("Main").Sort.SortFields.Add Key:=Range("B23"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Main").Sort
        .SetRange Range("B23:B422")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("B23").Select
       
    iBatchQty = Sheets("Main").Range("F20").Value
       
    MsgBox "There were " & iDuplicates & " duplicates found and removed."
      
    Call Get_Batch_Location(True)
        
    'Build file name for saving new request
    sNewFileName = sRequestPri & "_" & sClaimNo & "_" & iBatchQty
    
    'Set location equal to cell C4 on admin tab
    sNewLoc = Sheets("Admin").Range("C4").Value
    
    'Add a new workbook for the new request & assign it to variable
    Workbooks.Add
    Set wbNewFile = ActiveWorkbook
    
    'Save file in location set previously, using file format 6 (.csv)
    wbNewFile.SaveAs sNewLoc & sNewFileName, 6
    
    'Transfer the batch numbers to the newly created sheet, close new file & save
    wbNewFile.Sheets(1).Range("A1:A400").Value = wbCurrFile.Sheets("Main").Range("Requested_Batches").Value
    wbNewFile.Sheets(1).Range("B1:B400").Value = wbCurrFile.Sheets("Main").Range("Requested_Batch_Status").Value
    wbNewFile.Sheets(1).Range("M1").Value = "Date Requested:"
    wbNewFile.Sheets(1).Range("M2").Value = "Batches passed to GA Team:"
    wbNewFile.Sheets(1).Range("M3").Value = "Batches returned to PP:"
    wbNewFile.Sheets(1).Range("M4").Value = "Batches re-filed:"
    wbNewFile.Sheets(1).Range("P1").Value = Format(dRequestDate, "DD/MM/YY")
    wbNewFile.Close SaveChanges:=True
    
    'Clear batch request area
    wbCurrFile.Activate
    ActiveSheet.Unprotect ("smith85")
    Sheets("Main").Range("Requested_Batches").ClearContents
    Sheets("Main").Range("Requested_Batch_Status").ClearContents
    Sheets("Main").Range("B20").ClearContents
    Sheets("Main").Range("E20").ClearContents
    ActiveSheet.Protect ("smith85")
    
    'Find next blank row in Request History tab
    iRow = Worksheets("Request History").Cells.Find(What:="*", SearchOrder:=xlRows, _
    SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
    
    'Enter details of request into the Request History
    Sheets("Request History").Activate
    Cells(iRow, 1).Value = sClaimNo
    Cells(iRow, 2).Value = dRequestDate
    Cells(iRow, 3).Value = sRequestPri
    Cells(iRow, 4).Value = iBatchQty
    Cells(iRow, 5).Value = "New"
    
    Sheets("Main").Activate
        
'Housekeeping
Set wbCurrFile = Nothing
Set wbNewFile = Nothing
Application.ScreenUpdating = True
End Sub
Sub Get_Batch_Location(Optional NewRequest As Boolean)
'Declaration of variables
Dim wbDataFile As Workbook, wbCurrFile As Workbook
Dim vBatchNumbers(399) As Variant, vBatchData(399) As Variant
Dim i As Integer
Dim sBatchLoc As String, sTeamWith As String, sBatchLocData As String, sDataFileName As String
Dim dLastUpdated As Date, dLoggedOut As Date
Dim rCell As Range
Application.ScreenUpdating = False
    
    'Assignment of variables
    Set wbCurrFile = ActiveWorkbook
    sDataFileName = Sheets("Admin").Range("C3").Value
    i = 0
    
    'Add each of the batches listed, into the array
    If NewRequest Then
    
        For Each rCell In Range("Requested_Batches")
        
            vBatchNumbers(i) = rCell.Value
            i = i + 1
            
        Next rCell
        
    Else
    
        For Each rCell In Range("Batches_To_Check")
        
            vBatchNumbers(i) = rCell.Value
            i = i + 1
            
        Next rCell
    
    End If
    
    i = 0
    
    'Open the data file to retrieve batch data
    Workbooks.Open Filename:=sDataFileName, ReadOnly:=True
    Set wbDataFile = ActiveWorkbook
       
    Do While vBatchNumbers(i) <> ""
        
        'Find the batch number in the data file
        Cells.Find(What:=vBatchNumbers(i), SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Select
        
        'Assign the information relating to the batch, to variables
        sBatchLoc = ActiveCell.Offset(0, 1).Value
        dLastUpdated = ActiveCell.Offset(0, 2).Value
        
        'If the batch location information does not exist set the text equal to that
        If sBatchLoc = "" Then
        
            sBatchLocData = "There is no information for this batch in the data file."
        
        'If the batch location states "logged out" then assign the date and the team info to variables
        ElseIf sBatchLoc = "Logged out" Then
            
            dLoggedOut = ActiveCell.Offset(0, 4).Value
            sTeamWith = ActiveCell.Offset(0, 5).Value
            sBatchLocData = "This batch has been logged out by " & sTeamWith & " since " & dLoggedOut
            
        'If none of the above are true then the batch location is known to be in filing or archive
        Else
        
            sBatchLocData = "This batch is in " & sBatchLoc & ". " & "Last updated: " & dLastUpdated
                            
        End If
        
        'Assign the text to an element of the vBatchData array
        vBatchData(i) = sBatchLocData
        
        'Clear variables
        sBatchLoc = ""
        sTeamWith = ""
        sBatchLocData = ""
        dLastUpdated = 0
        dLoggedOut = 0
        
        i = i + 1
        
    Loop
    
    wbDataFile.Close
    i = 0
    wbCurrFile.Activate
    
    If NewRequest Then
    
        Sheets("Main").Range("D23").Select
    
    Else
    
        Sheets("Main").Range("D5").Select
    
    End If
    
    ActiveSheet.Unprotect ("smith85")
    
    'Cycle through the elements of the vBatchData array and write this to the main sheet
    Do While vBatchNumbers(i) <> ""
    
        ActiveCell.Value = vBatchData(i)
        ActiveCell.Offset(1, 0).Select
        i = i + 1
    
    Loop
    
    ActiveSheet.Protect ("smith85")
    
'Housekeeping
Set wbCurrFile = Nothing
Set wbDataFile = Nothing
Application.ScreenUpdating = True
End Sub

Thanks in advance!

 

[Damon Ostrander]

Hi Mark,

In looking at your code I see lots of places for slight improvements, but the only thing I can see that might give you a major improvement is to limit the Find operation. Using Cells.Find searches the entire worksheet. I'm wondering if this is really necessary, as it implies you have no idea where the vBatchNumbers(i) might occur in the worksheet. But if you have any idea where it cannot occur (e.g., certain rows or columns) you can limit the search to the places it can occur by using the limited range. For example, if it can only occur in columns 2 through 4 use

Columns("B:D").Find ...

I hope this helps.

Damon

 

[marksmith1985]

Hi Damon, I really appreciate you taking the time to respond, thank you. I amended to Columns("A").Find but noticed no difference really, the batch number is always stored in A so I imagine Cells.Find would search the whole of that column anyway? I'd be interested to know any other suggestions no matter how small as I'm always trying to improve the code I write. Thanks again, Mark

 

[ukmikeb]

Hi

You would be able to determine the number of duplicates by using Advanced Filter - unique, eg :-

Batcount = Range("A24:A" & Range("A" & Rows.Count).End(xlUp).Row).Rows.Count
Range("A23:A36").AdvancedFilter Action:=xlFilterCopy, Copytorange:=Range("D23:D36"), Unique:=True
Duprecs = Batcount + Range("D24:D" & Range("D" & Rows.Count).End(xlUp).Row).Rows.Count

I have used an extra column (D in this case) and have allowed for a header in cell A23, but it could be done in place, adjust references accordingly.

This method would save on the repetitive Countif against every cell in the range "Requested Batches" and the resultant Sort.

hth

 

[ukmikeb]

Correction :-

Duprecs = Batcount + Range("D24:D" & Range("D" & Rows.Count).End(xlUp).Row).Rows.Count

should read

Duprecs = Batcount - Range("D24:D" & Range("D" & Rows.Count).End(xlUp).Row).Rows.Count