Slow VBA/Macro - Need a more efficient code

[Kabasauls]

Hello,


Situation: Accounting database that needs to be matched based on the last two columns. Any unmatched rows are manually fixed.

A	B	C	D	E	F	G	H	I	J	K	L
Type	Nbr	Post	Auto Rev <tbody> </tbody>	Nbr <tbody> </tbody>	Nbr <tbody> </tbody>	Date <tbody> </tbody>	Create User <tbody> </tbody>	Description <tbody> </tbody>	Balance <tbody> </tbody>	Amount <tbody> </tbody>	Amount <tbody> </tbody>
AP	AD	65465	65464	X	Y	4-26	XXX	sdfsdfs	asdfd	0 <tbody> </tbody>	43053 <tbody> </tbody>
AP	AD	65481	21548	X	Y	4-12	XXX	sdfsdf	adfas	0	54152
AP	VO	46481	54123	X	Y	5-3	XXX	asdfasd	adsfa	43053	0

<tbody>
</tbody>

Logic: When the non-zero amount on column K matches the one in column L, the macro adds "Ok" to the side of the respective cells's row. The macro skips the already Okay-ed cells and only compares the missing "Ok" values. Once the macro attempts to match all the values, a filter is used to show only non-okay cells. These cells are the unmatched ones.


Issue: The macro works, but it takes about 27 minutes to complete with a database of 15000+ rows. I have tried to make the macro more efficient, but I have reached my limit with my current knowledge in excel.

I have read that instead of using a loop, a faster way to accomplish the task is to put the value in an array, and then transfer the array to the worksheet.

I don't want to lose the dynamic aspect of my current macro, where it adapts to the new database's number of rows. Can any one point my in the right direction?

Any help will be greatly appreciated.

Code:

Private Sub Scan()
Dim Rows1 As Long
Dim Rows2 As Long
Dim lastRow As Long
Dim i As Long
Dim m As Long
i = 1
m = 1
 
'Find number of rows with data
    With ActiveSheet
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    
'Scan first column
For i = 2 To lastRow
    For m = 2 To lastRow
    If Cells(i, 11).Value <> 0 And Cells(m, 12).Value <> 0 Then
        'Check for a blank cell
            If (Cells(i, 13).Value = "") And (Cells(m, 13).Value = "") Then
            'looks for a match
                If Cells(i, 11).Value = Cells(m, 12).Value Then
                    Cells(i, 13).Value = "Ok"
                    Cells(m, 13).Value = "Ok"
                End If
            End If
    End If
    Next m
Next i


End Sub

 

[Gavin T]

In the beginning of your macro add this line:

Application.ScreenUpdating = False

At the end add this:

Application.ScreenUpdating = True

 

[Kabasauls]

Gavin,

Thanks for the reply. I already have that in my code. What I posted is a piece of my overall code. There is a general sub that calls the Scan() sub. This is how it looks:

Private Sub CommandButton1_Click()

screenUpdateState = Application.ScreenUpdating
statusBarState = Application.DisplayStatusBar
calcState = Application.Calculation
eventsState = Application.EnableEvents
displayPageBreakState = ActiveSheet.DisplayPageBreaks 'note this is a sheet-level setting


'turn off some Excel functionality for faster performance
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False 'note this is a sheet-level setting


Call clear_formats
Call Scan
Call filter


'after your code runs, restore state
Application.ScreenUpdating = screenUpdateState
Application.DisplayStatusBar = statusBarState
Application.Calculation = calcState
Application.EnableEvents = eventsState
ActiveSheet.DisplayPageBreaks = displayPageBreaksState 'note this is a sheet-level setting


End Sub

 

[iliace]

This line of code:

If Cells(i, 11).Value <> 0 And Cells(m, 12).Value <> 0 Then

will never be true when Cells(i, 11) = 0. Therefore, you can move the first half of the If statement outside of the inner For loop.

With arrays, you still need to loop, but it should be considerably faster. Try this modified code:

Private Sub Scan()
  Dim Rows1 As Long
  Dim Rows2 As Long
  Dim lastRow As Long
  Dim i As Long
  Dim m As Long


  Dim vK As Variant
  Dim vL As Variant
  Dim vM As Variant
   
  'Find number of rows with data
  With ActiveSheet
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    vK = .Range("K1:K" & lastRow).Value
    vL = .Range("L1:L" & lastRow).Value
    vM = .Range("M1:M" & lastRow).Value
  End With
      
  'Scan first column
  For i = 2 To lastRow
    If vK(i, 1) <> 0 And Len(vK(i, 1)) > 0 Then
      For m = 2 To lastRow
        If vL(m, 1).Value <> 0 Then
          'Check for a blank cell
          If (vM(i, 1).Value = "") And (vM(m, 1).Value = "") Then
          'looks for a match
            If vK(i, 1).Value = vL(m, 1).Value Then
              Cells(i, 13).Value = "Ok"
              Cells(m, 13).Value = "Ok"
            End If
          End If
        End If
      Next m
    End If
  Next i
End Sub

 

[Kabasauls]

Iliace,

Thank you for your reply. I am getting a run time error '424': Object required when I attempt to run your code. This is the line it takes me to:

If vL(m, 1).Value <> 0 Then

What could be the reason?

Watches status:
i = 7493
m = 2
vL(m, 1).Value - Object required.
Array vL has data in every point.

 

[iliace]

Sorry - since it's an array, it doesn't need a .Value, just delete that part. Should be vL(m, 1) <> 0. Same for all the other ones.

 

[Kabasauls]

Got it!

It is considerably faster - from 27 minutes down to 2 minutes. That is amazing!

There is only one issue. It seems to be giving me a different answer than before. I check by comparing the differences from the sum of column K versus the sum of column L. If they are the same after the macro runs, then it works. I am now getting a smaller value, meaning I am matching numbers that should not be matched, most likely zeros with zeros.

The reason I had:

If Cells(i, 11).Value <> 0 And Cells(m, 12).Value <> 0 Then

is because I want to ignore any zeros being compared at all in any of the columns. I only want to compare non-zero numbers.

I am trying to understand your code. Why do you have:

              Cells(i, 13).Value = "Ok"
              Cells(m, 13).Value = "Ok"

Instead of modifying the array vM? From my understanding, wouldn't this leave the array blank during the matching process?

Thank you for taking the time to work this out with me.

 

[iliace]

Regarding the <>0, I changed that as part of optimization. They are both still checked., except vK(i, 1) is checked outside of the inner For loop and vL(m, 1) <> 0 condition is inside.

The problem must be somewhere else. I haven't tested this, but reviewing the logic it seems to be consistent with your code.

The very last part where you put OK back in the spreadsheet I left as is, since I didn't think it causes the delays. The alternative is to rewrite the entire array back to the range once you are done. If you feel this causes the slow down you can do this as well at the end:

ActiveSheet.Range("M1:M" & lastRow).Value = vM

and inside the loop would change to:

            If vK(i, 1) = vL(m, 1) Then
              vM(i, 1) = "Ok"
              vM(m, 1) = "Ok"
            End If

 

[iliace]

Here, try it this way instead, I think I found the problem. Starting at the first For loop.

  For i = 2 To lastRow
    If vK(i, 1) <> 0 And Len(vM(i, 1)) = 0 Then
      For m = 2 To lastRow
        If vL(m, 1) <> 0 Then
          'Check for a blank cell
          If (vM(i, 1) = "") And (vM(m, 1) = "") Then
          'looks for a match
            If vK(i, 1) = vL(m, 1) Then
              vM(i, 1) = "Ok"
              vM(m, 1) = "Ok"
            End If
          End If
        End If
      Next m
    End If
  Next i
  
  ActiveSheet.Range("M1:M" & lastRow).Value = vM
End Sub

 

[Kabasauls]

Iliace,

Once I added your modified code, the discrepancy was fixed. I am getting the result that I expected.

This is exactly what I needed. Thank you for your help!