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

https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba — BigBen, Jul 15 '20 at 15:40
Can you please post a sample of the data from the Variance sheet please, including data to be excluded? — Applecore, Jul 15 '20 at 15:52
@Applecore I've included an image with sample data if that will help. — Allan David, Jul 15 '20 at 17:02
@Dorian, you are right, but I'm currently limited to excel VBA, — Allan David, Jul 15 '20 at 17:04
@Dorian, you mean add it like a library? If you have some posts on how to do that, please link me to it. You must've figured out by now, I'm pretty new to the VBA environment. My core job is not programming but to use tools like excel for designing solutions. I started with macros to make things easier and to save time. — Allan David, Jul 15 '20 at 17:10

score 1 · Answer 1 · answered Jul 15 '20 at 17:22

1

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/

answered Jul 15 '20 at 17:22

TourEiffel

4,034
2
16
45

thanks a lot, I’ll go through the link and try to get a hold of it. – Allan David Jul 15 '20 at 18:03

Tim Williams · Answer 2 · 2020-07-15T23:18:41.813

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

Wow!! Thanks a lot. I’ll run it and let you know the results. — Allan David, Jul 16 '20 at 12:14
Hi again Tim, I tweaked the columns and made a change in the if condition for v (if v<> 0), it works perfectly like magic. The best part is, it doesn't even take a second. Once again, Thanks a lot. — Allan David, Jul 18 '20 at 11:56
If you don't mind, a doubt, you've defined a constant up to 30K rows right? If the output in the vertical sheet exceeds that number, I guess I'll get an error? Can I increase the number manually to a bigger one? — Allan David, Jul 18 '20 at 12:29
No it will not error - that 30k value is how many output rows get "collected" before being written to the sheet: when that happens the array is emptied and re-filled with the next set of output rows, and that happens `[your # of rows]/BLOCK_SIZE` times (rounded up). Try reducing the BLOCK_SIZE to something like 100 and see what happens. — Tim Williams, Jul 18 '20 at 17:27
Thanks again, sorry I forgot to take a closer look at the second last if statement that refills the next set of output. I get it crystal clear now. Once again thanks a lot, that saves a huge amount of time. — Allan David, Jul 18 '20 at 18:24

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

2 Answers2