How could I make VBA code faster

[nhnn1986]

Hi all.

I have vba code belove to check data, Code work well if have lest than 1000 rows. But my Source data have over 50000 rows so code work very slow

Please help me to improve code to do faster. Thanks

 Sub check()
 dim lrow as long, cel as range, ws, wsSource, wsFault as sheet
 Dim val, val1, val2, val3, val4 As Double
set wsSource = thisworkbook.sheets("Source")
Set wsFault = thisworkbook.sheets("fault")
    with wsSource
        For Each cel In .Range("B2:B" & lrow)
            lrow = wsFault.Cells(Rows.Count, 1).End(xlUp).Row
            val1 = Abs(.Cells(cel.Row, "D") + .Cells(cel.Row, "F") - .Cells(cel.Row, "H"))
            val2 = Abs(.Cells(cel.Row, "E") + .Cells(cel.Row, "G") - .Cells(cel.Row, "I"))
                If (val1 > 0) Or (val2) > 0 Then .Rows(cel.Row).Copy wsFault.Range("A" & lrow + 1)
            If IsNumeric(Right(cel.Value, 1)) Then
                .Cells(cel.Row, "C").Value = "check_Fault"
                    For i = 4 To 9
                        val = .Cells(cel.Row, i).Value - WorksheetFunction.Sum(.Range(.Cells(cel.Row + 1, i), .Cells(cel.Row + 13, i)).Value)
                        lrow = wsFault.Cells(Rows.Count, 1).End(xlUp).Row
                        If Abs(val) > 0 Then
                            wsFault.Range("A" & lrow + 1).Value = .Range("A" & cel.row).Value
                            wsFault.Range("B" & lrow + 1).Value = "Fault in column: " & .Columns(i).Address & ", rows: " & cel.Row & "_" & cel.Row + 13
                        end if
                    Next
            End If
        Next
    ' ===Finish check =========
    End With
    
end sub

 

[offthelip]

try this ( untested) which uses varaint arrays to speed up the process:

Sub check()
 Dim temparr(1 To 1, 1 To 9)
 Dim lrow As Long, cel As Range, ws, wsSource, wsFault As Worksheet
 Dim val, val1, val2, val3, val4 As Double
Set wsSource = ThisWorkbook.Sheets("Source")
Set wsFault = ThisWorkbook.Sheets("fault")
    With wsSource
   lastrow = .Cells(Rows.Count, "B").End(xlUp).Row  ' find the last row in wsource sheet which you weren't doing
   inarr = .Range(.Cells(1, 1), .cell(lastrow, 9)) ' load the whole sheet columns A to I into a variant array
   lrow = wsFault.Cells(Rows.Count, 1).End(xlUp).Row  'move this out of the loop to speed things up
  
   '      For Each cel In .Range("B2:B" & lrow)
           For j = 1 To lastrow
             val1 = Abs(inarr(j, 4) + inarr(j, 5) - inarr(j, 8))
            val2 = Abs(inarr(j, 5) + inarr(j, 7) - inarr(j, 9))
'                If (val1 > 0) Or (val2) > 0 Then .Rows(cel.Row).Copy wsFault.Range("A" & lrow + 1)
                If (val1 > 0) Or (val2) > 0 Then
                 For k = 1 To 9
                  temparr(1, k) = inarr(j, k) ' copy the row to temp variant array
                 Next k
                  wsFault.Range("A" & lrow + 1) = temparr
                  lrow = lrow + 1              ' increment the count instead of checking the workhsetagain is much faster
                End If
            If IsNumeric(Right(inarr(j, 2), 1)) Then
                .Cells(j, 3).Value = "check_Fault"
                    For i = 4 To 9
                        val = .Cells(j, i).Value - WorksheetFunction.Sum(.Range(.Cells(j + 1, i), .Cells(j + 13, i)).Value)
                        lrow = wsFault.Cells(Rows.Count, 1).End(xlUp).Row
                        If Abs(val) > 0 Then
                            wsFault.Range("A" & lrow + 1).Value = .Range("A" & j).Value
                            wsFault.Range("B" & lrow + 1).Value = "Fault in column: " & .Columns(i).Address & ", rows: " & j & "_" & j + 13
                        End If
                    Next
            End If
        Next
    ' ===Finish check =========
    End With
    
End Sub

 

[nhnn1986]

Thanks @offthelip for your respond

 

[offthelip]

I have spotted one errorin my code I wasn't controlling lrow correctly: try this:

 Sub check()
 Dim temparr(1 To 1, 1 To 9)
 Dim lrow As Long, cel As Range, ws, wsSource, wsFault As Worksheet
 Dim val, val1, val2, val3, val4 As Double
Set wsSource = ThisWorkbook.Sheets("Source")
Set wsFault = ThisWorkbook.Sheets("fault")
    With wsSource
   lastrow = .Cells(Rows.Count, "B").End(xlUp).Row  ' find the last row in wsource sheet which you weren't doing
   inarr = .Range(.Cells(1, 1), .cell(lastrow, 9)) ' load the whole sheet columns A to I into a variant array
   lrow = wsFault.Cells(Rows.Count, 1).End(xlUp).Row  'move this out of the loop to speed things up
 
   '      For Each cel In .Range("B2:B" & lrow)
           For j = 1 To lastrow
             val1 = Abs(inarr(j, 4) + inarr(j, 5) - inarr(j, 8))
            val2 = Abs(inarr(j, 5) + inarr(j, 7) - inarr(j, 9))
'                If (val1 > 0) Or (val2) > 0 Then .Rows(cel.Row).Copy wsFault.Range("A" & lrow + 1)
                If (val1 > 0) Or (val2) > 0 Then
                 For k = 1 To 9
                  temparr(1, k) = inarr(j, k) ' copy the row to temp variant array
                 Next k
                  wsFault.Range("A" & lrow + 1) = temparr
                  lrow = lrow + 1              ' increment the count instead of checking the workhsetagain is much faster
                End If
            If IsNumeric(Right(inarr(j, 2), 1)) Then
                .Cells(j, 3).Value = "check_Fault"
               
                    For i = 4 To 9
                        val = .Cells(j, i).Value - WorksheetFunction.Sum(.Range(.Cells(j + 1, i), .Cells(j + 13, i)).Value)
               '         lrow = wsFault.Cells(Rows.Count, 1).End(xlUp).Row
                        If Abs(val) > 0 Then
                            wsFault.Range("A" & lrow).Value = .Range("A" & j).Value
                            wsFault.Range("B" & lrow).Value = "Fault in column: " & .Columns(i).Address & ", rows: " & j & "_" & j + 13
                             lrow = lrow + 1
                       End If
                    Next
                
            End If
        Next
    ' ===Finish check =========
    End With
   
End Sub