VBA - Code works fine but takes 35-40 mins sometimes longer to update

[Eisasuarez]

Hi All,

Im hoping you can help me speed up this code - Im manipulating some data and pasting it into each row on the output sheet. This code takes so long to run and was hoping you can help me speed this up.

Now it could be because ive got loads of stuff going on in my original sheet and the data workbook has loads of data, its processing slowly and pasting each row at a time is taking long

Now i Know ive read that if i can do the same and load it all into an array and process it all right at the end - this will speed it up but i dont know how

Arrays is something i still struggle with so was hoping someone could help me change the code so it stores into an array and outputs at then end or speed up this code some how please

Like i said - this code works fine but takes forever to process - i tried doing all the calculation 1st in the data workbook and then doing a copy & paste rather than pasting straight into the main file but that did not quicken it by much so im guessing array is the way to go - please can someone help me

Thank you so much

Option Explicit
 
' Defined data type to hold data about the Agent
Private Type Agent
    sURN As String
    sName As String
    sManager As String
    sDepartment As String
End Type
 
' Defined data type to hold all the data about a test
Private Type Test
    sTestName As String
    dDate As Date
    lScore As Long
    sPassed As String
    iAttempt As Integer
End Type
   
Public Sub Update()
    Dim sFolder As String, sFile As String
    Dim wbData As Workbook
    Dim wbOutputSh As Worksheet
    Dim shData As Worksheet
    Dim rgAgents As Range, rgAgent As Range
    Dim aAgent As Agent
    Dim tTest As Test
    Dim lPasteRow As Long, lTestRange As Long, lCurCol As Long
    Dim dStart As Double: dStart = Now
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    MsgBox "This takes around 40-50 minutes to Run!", vbInformation, "Alert!"
    ' Get folder & filename of the Assessement workbook
    sFolder = ThisWorkbook.Sheets("LookUp").Range("Data_Folder")
    sFile = ThisWorkbook.Sheets("LookUp").Range("Data_File")
   
    ' Load Assessment workbook and set row where first record will be copied to
    On Error GoTo ErrorFound:
        Set wbData = Workbooks.Open(sFolder & sFile, ReadOnly:=True)
        Set wbOutputSh = wbData.Worksheets("CleanUp")
       
        Call ClearPerformanceData(ThisWorkbook, wbData)
        lPasteRow = 2
    On Error Resume Next
   
    ' Loop through each sheet in Assessment
    For Each shData In wbData.Sheets
        ' Check to see if this is a sheet with Assessment data on it
        If shData.Range("A1").Value = "URN" And shData.Name <> "CleanUp" Then
            ' Set out how many columns we need to go across for all the assessments
            lTestRange = shData.Range("D2").End(xlToRight).Column
            ' Set a range for the agents on this sheet
            Set rgAgents = Range(shData.Range("A3"), shData.Range("A3").End(xlDown))
            Debug.Print rgAgents.Count
           
            For Each rgAgent In rgAgents
                Application.StatusBar = "Working On " & shData.Name & " - (" & rgAgent.Row & " Of " & rgAgents.Count & ")"
                ' Set up the data relevant to this agent
                aAgent.sURN = rgAgent
                aAgent.sName = rgAgent.Offset(0, 1)
                aAgent.sManager = rgAgent.Offset(0, 2)
                aAgent.sDepartment = shData.Name ' possibly a lookup to something else if preferred
           
                ' Loop through the columns for the assessment data
                For lCurCol = 4 To lTestRange
                    ' Check the heading in Row 2
                    Select Case Trim(shData.Cells(2, lCurCol).Value)
                        ' If 'Assessment Date' then set the test date, test name & set attempt to 1
                        Case Is = "Assessment Date"
                            tTest.dDate = shData.Cells(rgAgent.Row, lCurCol)
                           
' This if is to catch if the Assessment Date cell has a blank space above it - if so then use the cell 1 up & 1 left
' of the Assessment Date cell. If the sheet has standardised headings then the 'ELSE' part can be used on all sheets
                            If IsEmpty(shData.Cells(1, lCurCol)) = True Then
                                tTest.sTestName = shData.Cells(1, lCurCol + 1)
                            Else
                                tTest.sTestName = shData.Cells(1, lCurCol)
                            End If
                            tTest.iAttempt = 1
                       
                        ' If 'Score' then set the score & whether passed or not
                        Case Is = "Score"
                            tTest.lScore = shData.Cells(rgAgent.Row, lCurCol)
                            tTest.sPassed = shData.Cells(rgAgent.Row, lCurCol + 1)
                           
                            ' Then print the data if a score actually exists
                            If IsEmpty(shData.Cells(rgAgent.Row, lCurCol)) = False Then
                                PrintData aAgent, tTest, lPasteRow, wbOutputSh
                                lPasteRow = lPasteRow + 1
                            End If
                        Case Is = "Passed/Failed"
                            ' Add 1 to the attempt in case they failed
                            tTest.iAttempt = tTest.iAttempt + 1
                    End Select
                Next lCurCol
            Next rgAgent
        End If
    Next shData
   
    wbOutputSh.ListObjects("Data").DataBodyRange.Copy ThisWorkbook.Worksheets("CleanUp").Range("A2")
   
    wbData.Close (False)
   
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
    Application.Goto Worksheets("Dashboard").Range("a1"), True
 
    Debug.Print Format(Now - dStart, "hh:mm:ss")
    Exit Sub
 
ErrorFound:
    MsgBox "You dont have access to the Master Assessment File" & vbCrLf & "Please Contact the WFM team", vbOKOnly, "Access Denied"
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
    Application.Goto Worksheets("Dashboard").Range("A1"), True
 
End Sub
 
' If the CleanUp sheet is altered / changed then the numbers in the Cells need to be tweaked / updated
Private Sub PrintData(pAgent As Agent, pTest As Test, pPasteRow As Long, OutputSh As Worksheet)
    With OutputSh
        .Cells(pPasteRow, 1).Value = pAgent.sURN
        .Cells(pPasteRow, 2).Value = pAgent.sName
        .Cells(pPasteRow, 3).Value = pAgent.sManager
        .Cells(pPasteRow, 5).Value = pAgent.sDepartment
        .Cells(pPasteRow, 6).Value = pTest.dDate
        .Cells(pPasteRow, 8).Value = "Attempt " & pTest.iAttempt
        .Cells(pPasteRow, 9).Value = pTest.sTestName
        .Cells(pPasteRow, 10).Value = pTest.lScore
        .Cells(pPasteRow, 11).Value = pTest.sPassed
    End With
End Sub
 
Private Sub ClearPerformanceData(wbThisworkbook As Workbook, wbData As Workbook)
   
    Dim CleanUpSh As Worksheet
    Dim CleanUpSh2 As Worksheet
   
    Dim tbTable As ListObject
    Dim tbTable2 As ListObject
   
    Set CleanUpSh = wbThisworkbook.Worksheets("CleanUp")
    Set CleanUpSh2 = wbData.Worksheets("CleanUp")
   
    Set tbTable = CleanUpSh.ListObjects("Data")
    Set tbTable2 = CleanUpSh2.ListObjects("Data")
   
    If Not tbTable.DataBodyRange Is Nothing Then tbTable.DataBodyRange.Delete
    If Not tbTable2.DataBodyRange Is Nothing Then tbTable2.DataBodyRange.Delete
   
End Sub