Slow VBA/Macro - Need a more efficient code

K

Kabasauls

New Member
Joined
Jul 12, 2012
Messages
24
Hello,


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


[TABLE="class: outer_border, width: 500, align: center"]
<tbody>[TR]
[TD="align: center"]A[/TD]
[TD="align: center"]B[/TD]
[TD="align: center"]C[/TD]
[TD="align: center"]D[/TD]
[TD="align: center"]E[/TD]
[TD="align: center"]F[/TD]
[TD="align: center"]G[/TD]
[TD="align: center"]H[/TD]
[TD="align: center"]I[/TD]
[TD="align: center"]J[/TD]
[TD="align: center"]K[/TD]
[TD="align: center"]L[/TD]
[/TR]
[TR]
[TD="align: center"]Type[/TD]
[TD="align: center"]Nbr[/TD]
[TD="align: center"]Post[/TD]
[TD][TABLE="class: cms_table, width: 54"]
<tbody>[TR="class: outer_border"]
[TD="width: 54, align: center"]Auto Rev[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="class: cms_table, width: 54"]
<tbody>[TR="class: outer_border"]
[TD="width: 54, align: center"]Nbr[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="class: cms_table, width: 54"]
<tbody>[TR="class: outer_border"]
[TD="width: 54, align: center"]Nbr[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="class: cms_table, width: 54"]
<tbody>[TR="class: outer_border"]
[TD="width: 54, align: center"]Date[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="class: cms_table, width: 54"]
<tbody>[TR="class: outer_border"]
[TD="width: 54, align: center"]Create User[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="class: cms_table, width: 54"]
<tbody>[TR="class: outer_border"]
[TD="width: 54, align: center"]Description[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="class: cms_table, width: 54"]
<tbody>[TR="class: outer_border"]
[TD="width: 54, align: center"]Balance[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="class: cms_table, width: 54"]
<tbody>[TR="class: outer_border"]
[TD="width: 54, align: center"]Amount[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="class: cms_table, width: 54"]
<tbody>[TR="class: outer_border"]
[TD="width: 54, align: center"]Amount[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
[TR]
[TD="align: center"]AP[/TD]
[TD="align: center"]AD[/TD]
[TD="align: center"]65465[/TD]
[TD="align: center"]65464[/TD]
[TD="align: center"]X[/TD]
[TD="align: center"]Y[/TD]
[TD="align: center"]4-26[/TD]
[TD="align: center"]XXX[/TD]
[TD="align: center"]sdfsdfs[/TD]
[TD="align: center"]asdfd[/TD]
[TD][TABLE="class: cms_table, width: 54"]
<tbody>[TR="class: outer_border"]
[TD="width: 54, align: center"]0[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="class: cms_table, width: 83"]
<tbody>[TR="class: outer_border"]
[TD="width: 83, align: center"]43053[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
[TR]
[TD="align: center"]AP[/TD]
[TD="align: center"]AD[/TD]
[TD="align: center"]65481[/TD]
[TD="align: center"]21548[/TD]
[TD="align: center"]X[/TD]
[TD="align: center"]Y[/TD]
[TD="align: center"]4-12[/TD]
[TD="align: center"]XXX[/TD]
[TD="align: center"]sdfsdf[/TD]
[TD="align: center"]adfas[/TD]
[TD="align: center"]0[/TD]
[TD="align: center"]54152[/TD]
[/TR]
[TR]
[TD="align: center"]AP[/TD]
[TD="align: center"]VO[/TD]
[TD="align: center"]46481[/TD]
[TD="align: center"]54123[/TD]
[TD="align: center"]X[/TD]
[TD="align: center"]Y[/TD]
[TD="align: center"]5-3[/TD]
[TD="align: center"]XXX[/TD]
[TD="align: center"]asdfasd[/TD]
[TD="align: center"]adsfa[/TD]
[TD="align: center"]43053[/TD]
[TD="align: center"]0[/TD]
[/TR]
</tbody>[/TABLE]


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:
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
 

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.
Sort by date Sort by votes
In the beginning of your macro add this line:

Code: 
Application.ScreenUpdating = False

At the end add this:
Code: 
Application.ScreenUpdating = True
 
Upvote 0
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:

Code: 
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
 
Upvote 0
This line of code:

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:


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
 
Upvote 0
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:

Code: 
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.
 
Last edited:
Upvote 0
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.
 
Upvote 0
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:

Code: 
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:

Code: 
              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.
 
Upvote 0
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:

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


and inside the loop would change to:

Code: 
            If vK(i, 1) = vL(m, 1) Then
              vM(i, 1) = "Ok"
              vM(m, 1) = "Ok"
            End If
 
Upvote 0
Here, try it this way instead, I think I found the problem. Starting at the first For loop.

Code: 
  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
 
Upvote 0
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!
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Solved
If Else Loop macro running slow, anyway to speed it up?
Replies
9
Views
258
Alex Blakenburg
A
S
  • Question Question
Help with combining 2 macros into 1
Replies
8
Views
248
MARK858
MARK858
S
  • Question Question
Macro Copy and Paste Value and formatting in multiple same cells when condition is met.
Replies
4
Views
276
RobP
R
Guna13
  • Question Question
How to Efficient way for create Multiple Workbooks
Replies
1
Views
383
Guna13
Guna13
T
  • Question Question
Slow macro
Replies
5
Views
295
topi1
T

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top