Can I make my VBA code work Faster? it currently takes 7 minutes to look through 1300 rows and 500 columns

Question

Variance Table Sample I'm working on an Excel Macros (VBA) to look through every 3rd cell of each row in a data set and perform a copy paste action based on conditions (Please see the code at the bottom).

The source data is in a another worksheet (Variance). It has 1300+ IDs (rows) and 3 columns for each value component (col 1 - value 1, col 2 - value 2, and col 3 - the difference between the 2 values) and likewise there are 500+ columns.

My code basically looks through every third column (the difference column) of each row to find out if the value is a number, not equal to zero, and if it's not an error (there are errors in the source sheet). If yes, it copies the Emp ID, the column Name, and both the values into another worksheet called vertical analysis (one below the other).

The code works fine, but it takes 6 to 7 minutes for a data set with 1000+ rows and 500+ columns.

Can someone please tell me if there is a faster way to do this than to loop through each row?

Please let me know if you need more information. Thanks in advance.

Code:

Sub VerticalAnalysis()
  Dim EmpID As Range
  Dim i As Long
  Dim cell As Range
  Dim lastrow As Range
  Dim LastCol As Long
  Dim curRow As Long
  Dim c As Long
  
  Set lastrow = ThisWorkbook.Worksheets("Variance").Cells(Rows.Count, 2).End(xlUp)
  Set EmpID = ThisWorkbook.Worksheets("Variance").Range("B4", lastrow)
  LastCol = ThisWorkbook.Worksheets("Variance").Cells(3, Columns.Count).End(xlToLeft).Column
  
  Application.ScreenUpdating = False
  
  MsgBox "Depending on the size of the record, your excel will not respond for several minutes during Vertical Analysis. Please don't close the workbook", , "Note: Please Don't Close the Workbook"
  
  Worksheets("Vertical").Select
    
  Range("B3", "H" & Rows.Count).ClearContents
  Range("B3", "H" & Rows.Count).ClearFormats
  
  ThisWorkbook.Worksheets("Variance").Select
  
  c = 1
    
  For Each cell In EmpID
  
  i = 2
 
  Do Until i >= LastCol
   cell.Offset(0, i).Select
      
   If IsError(ActiveCell) Then
      
   ElseIf ActiveCell <> "" Then
            
    If IsNumeric(ActiveCell) = True Then
            
      If ActiveCell <> 0 Then
            
       cell.Copy
       Worksheets("Vertical").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
       ActiveCell.Offset(-c, -2).Copy
       Worksheets("Vertical").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
       ActiveCell.Offset(0, -2).Copy
       Worksheets("Vertical").Range("D" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
       ActiveCell.Offset(0, -1).Copy
       Worksheets("Vertical").Range("E" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
              
       End If
                    
       End If
      
       End If
      
    i = i + 4
      
    Loop
    
    c = c + 1
    
  Next cell
  
  ThisWorkbook.Worksheets("Vertical").Select
  Range("B2").Select

  MsgBox "Analysis complete " & vbCrLf & Worksheets("Vertical").Range("B" & Rows.Count).End(xlUp).Row - 2 & " Components have variations", , "Success!"


Application.ScreenUpdating = True

End Sub

Answer 1

Better not to hit the sheet so many times.

Below is tested and should run in a few seconds, but you may need to tweak the column positions etc:

Sub VerticalAnalysis()

    Const BLOCK_SIZE As Long = 30000
    Dim lastrow As Long
    Dim LastCol As Long
    Dim c As Long, wsVar As Worksheet, wsVert As Worksheet, n As Long
    Dim data, r As Long, empId, v, rwVert As Long, dataVert, i As Long
    
    Set wsVar = ThisWorkbook.Worksheets("Variance")
    Set wsVert = ThisWorkbook.Worksheets("Vertical")
    
    lastrow = wsVar.Cells(Rows.Count, 2).End(xlUp).Row
    LastCol = wsVar.Cells(3, Columns.Count).End(xlToLeft).Column
    
    'get all the input data as an array (including headers)
    data = wsVar.Range("A3", wsVar.Cells(lastrow, LastCol)).Value
    
    'clear the output sheet and set up the "transfer" array
    With wsVert.Range("B3", "H" & Rows.Count)
      .ClearContents
      .ClearFormats
    End With
    rwVert = 3                                'first "vertical" result row
    ReDim dataVert(1 To BLOCK_SIZE, 1 To 4)   'for collecting matches
    
    i = 0
    n = 0
    
    For r = 2 To UBound(data, 1)  'loop rows of input array
        empId = data(r, 2) 'colB ?
        c = 7              'first "difference" column ?
        Do While c <= UBound(data, 2)
            v = data(r, c)
            If Not IsError(v) Then
                If IsNumeric(v) Then
                    If v > 0.7 Then
                        i = i + 1
                        n = n + 1
                        dataVert(i, 1) = empId
                        dataVert(i, 2) = data(1, c)     'header
                        dataVert(i, 3) = data(r, c + 2) 'value1
                        dataVert(i, 4) = data(r, c + 1) 'value2
                        'have we filled the temporary "transfer" array?
                        If i = BLOCK_SIZE Then
                            wsVert.Cells(rwVert, 2).Resize(BLOCK_SIZE, 4).Value = dataVert
                            i = 0
                            ReDim dataVert(1 To BLOCK_SIZE, 1 To 4)
                            rwVert = rwVert + BLOCK_SIZE
                        End If
                    End If
                End If
            End If
            c = c + 4 'next difference
        Loop
    Next r
  
    'add any remaining
    If i > 0 Then wsVert.Cells(rwVert, 2).Resize(BLOCK_SIZE, 4).Value = dataVert
    
    wsVert.Select
    wsVert.Range("B2").Select
    
    MsgBox "Analysis complete " & vbCrLf & n & " Components have variations", , "Success!"

End Sub

Answer 2

You might try to use SQL. In order to learn how to use sql in EXCEL VBA, I suggest you to follow this tuto and to apply your learn on your macro. They will be faster =)

https://analystcave.com/excel-using-sql-in-vba-on-excel-data/