How to loop range of cells faster and smaller-CodePudding

Currently this is taking around 30 mins to finish as the if conditions are checking 25000 rows and 168 columns. This is just one function and I need to make around 10 more of such functions, so it will take a lot of time for the program to finish. Is there any way I can make this faster and simpler. Any help will be appreciated.. thanks

Sub SumBasicPay()
Application.ScreenUpdating = False

    Dim total As Double
    Dim ws1 As Worksheet
    Dim LastRow As Long
        
    Set ws1 = ThisWorkbook.Worksheets("Main")
    
    
    Worksheets("Database").Activate
    LastRow = Range("A1").CurrentRegion.Rows.Count
    
     For iRow = 2 To LastRow
         total = 0
         For iCol = 17 To 168
             If Cells(1, iCol).Value = Sheet12.Range("A7") And Sheet12.Range("B7") = " " Then
                 total = total   Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A7") And Sheet12.Range("B7") = "-" Then
                 total = total - Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A8") And Sheet12.Range("B8") = " " Then
                 total = total   Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A8") And Sheet12.Range("B8") = "-" Then
                 total = total - Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A9") And Sheet12.Range("B9") = " " Then
                 total = total   Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A9") And Sheet12.Range("B9") = "-" Then
                 total = total - Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A10") And Sheet12.Range("B10") = " " Then
                 total = total   Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A10") And Sheet12.Range("B10") = "-" Then
                 total = total - Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A11") And Sheet12.Range("B11") = " " Then
                 total = total   Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A11") And Sheet12.Range("B11") = "-" Then
                 total = total - Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A12") And Sheet12.Range("B12") = " " Then
                 total = total   Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A12") And Sheet12.Range("B12") = "-" Then
                 total = total - Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A13") And Sheet12.Range("B13") = " " Then
                 total = total   Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A13") And Sheet12.Range("B13") = "-" Then
                 total = total - Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A14") And Sheet12.Range("B14") = " " Then
                 total = total   Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A14") And Sheet12.Range("B14") = "-" Then
                 total = total - Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A15") And Sheet12.Range("B15") = " " Then
                 total = total   Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A15") And Sheet12.Range("B15") = "-" Then
                 total = total - Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A16") And Sheet12.Range("B16") = " " Then
                 total = total   Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A16") And Sheet12.Range("B16") = "-" Then
                 total = total - Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A17") And Sheet12.Range("B17") = " " Then
                 total = total   Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A17") And Sheet12.Range("B17") = "-" Then
                 total = total - Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A18") And Sheet12.Range("B18") = " " Then
                 total = total   Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A18") And Sheet12.Range("B18") = "-" Then
                 total = total - Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A19") And Sheet12.Range("B19") = " " Then
                 total = total   Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A19") And Sheet12.Range("B19") = "-" Then
                 total = total - Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A20") And Sheet12.Range("B20") = " " Then
                 total = total   Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A20") And Sheet12.Range("B20") = "-" Then
                 total = total - Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A21") And Sheet12.Range("B21") = " " Then
                 total = total   Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A21") And Sheet12.Range("B21") = "-" Then
                 total = total - Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A22") And Sheet12.Range("B22") = " " Then
                 total = total   Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A22") And Sheet12.Range("B22") = "-" Then
                 total = total - Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A23") And Sheet12.Range("B23") = " " Then
                 total = total   Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A23") And Sheet12.Range("B23") = "-" Then
                 total = total - Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A24") And Sheet12.Range("B24") = " " Then
                 total = total   Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A24") And Sheet12.Range("B24") = "-" Then
                 total = total - Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A25") And Sheet12.Range("B25") = " " Then
                 total = total   Cells(iRow, iCol).Value
             End If
             
             If Cells(1, iCol).Value = Sheet12.Range("A25") And Sheet12.Range("B25") = "-" Then
                 total = total - Cells(iRow, iCol).Value
             End If
             
             
             
         Next iCol            
         ws1.Cells(iRow, 1).Value = total  
     Next iRow

End Sub

If any more information is required, please do let me know.

Edit : Thanks for the answer @WojciechWojtulewski. Below is the updated code now after modifications which is taking 10 mins to complete instead of 25 mins.

Sub SumBasicPay()
Application.ScreenUpdating = False

    Dim total As Double
    Dim ws1 As Worksheet
    Dim LastRow As Long
        
    Set ws1 = ThisWorkbook.Worksheets("Main")
        
                
    Worksheets("Database").Activate
    LastRow = Range("A1").CurrentRegion.Rows.Count
    
    For iRow = 2 To LastRow
     total = 0
     For iCol = 17 To 168
        For abc = 7 To 25
            If Cells(1, iCol).Value = Sheet12.Cells(abc, 1).Value And Sheet12.Cells(abc, 2) = " " Then
                total = total   Cells(iRow, iCol).Value
            ElseIf Cells(1, iCol).Value = Sheet12.Cells(abc, 1).Value And Sheet12.Cells(abc, 2) = "-" Then
                total = total - Cells(iRow, iCol).Value
            End If
         Next
     Next iCol
     ws1.Cells(iRow, 1).Value = total
 Next iRow

End Sub

If anyone can provide the array method that takes less time to complete, that will be much appreciated

CodePudding user response：

Sum Up By Using Arrays

This took between 20 and 25 seconds for 50,000 records (rows) on my machine.

Option Explicit

Sub SumBasicPay()
    
    Dim dTime As Double: dTime = Timer ' start measuring the time passed
    
    ' Source
    Const sfRow As Long = 2
    Const sfCol As Long = 17
    Const slCol As Long = 168
    ' Lookup
    Const lrgAddress As String = "A7:B25"
    ' Destination
    Const dFirst As String = "A2"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    
    Dim sws As Worksheet: Set sws = wb.Worksheets("Database")
    Dim strg As Range: Set strg = sws.Range("A1").CurrentRegion
    
    If strg.Columns.Count < slCol Then Exit Sub ' not enough columns
    
    Dim srCount As Long: srCount = strg.Rows.Count
    If srCount < 2 Then Exit Sub ' not enough rows
    
    Dim scCount As Long: scCount = slCol - sfCol   1
    Dim scrg As Range: Set scrg = sws.Columns(sfCol).Resize(, scCount)
    
    Dim srg As Range: Set srg = Intersect(strg, scrg)
    
    Dim sData As Variant: sData = srg.Value
    
    ' Lookup
    Dim lws As Worksheet: Set lws = Sheet12
    Dim lrg As Range: Set lrg = lws.Range(lrgAddress)
    Dim lrCount As Long: lrCount = lrg.Rows.Count
    Dim lData As Variant: lData = lrg.Value
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets("Main")
    Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
    Dim drCount As Long: drCount = srCount - 1
    Dim drg As Range: Set drg = dfCell.Resize(drCount)
    Dim dData() As Double: ReDim dData(1 To drCount, 1 To 1)
    
    ' For...Next Loop Additional Variables
    Dim sLookup As Variant
    Dim sMatch As Variant
    Dim sr As Long
    Dim sc As Long
    Dim lr As Long
    Dim Total As Double
    
    ' Total
    For sr = 2 To srCount
        Total = 0
        For sc = 1 To scCount
            sLookup = sData(1, sc) ' the value in the first row
            If IsNumeric(sLookup) Then ' lookup is a number
                sMatch = sData(sr, sc) ' the value in the current row
                If IsNumeric(sMatch) Then ' match is a number
                    For lr = 1 To lrCount
                        If lData(lr, 1) = sLookup Then ' lookup is equal
                            Select Case CStr(lData(lr, 2))
                            Case " "
                                Total = Total   sMatch
                            Case "-"
                                Total = Total - sMatch
                            'Case Else ' neither ' ' nor '-' (do nothing)
                            End Select
                        'Else ' lookup is not equal (do nothing)
                        End If
                    Next lr
                'Else ' match is not a number
                End If
            'Else ' lookup is not a number (do nothing)
            End If
        Next sc
        dData(sr - 1, 1) = Total
    Next sr

    ' Write
    drg.Value = dData
    
    Debug.Print Timer - dTime ' end measuring and print the time passed
    
    MsgBox "Summed up Basic Pay.", vbInformation
    
End Sub

CodePudding user response：

For iRow = 2 To LastRow
     total = 0
     For iCol = 17 To 168
        For iRow = 7 To 25
            If Cells(1, iCol).Value = Sheet12.Celss(iRow, 1).Value And Sheet12.Cells(iRow, 2) = " " Then
                total = total   Cells(iRow, iCol).Value
            Else
                total = total - Cells(iRow, iCol).Value
            End If
         Next
     Next iCol
     ws1.Cells(iRow, 1).Value = total
 Next iRow