Macro Maxing Out CPU

A

andybason

Board Regular
Joined
Jan 7, 2012
Messages
217
Office Version
  1. 2016
Hi,

I have the macro below that works ok but tends to max out my cpu. From testing I have identified the following section as the main cause:

VBA Code: 
'Count the last cell where to start copying
Dim b As Long
b = 2
For i = 2 To 100000
If ThisWorkbook.Sheets("Data").Cells(i, 1) <> "" Then
b = b + 1
End If
Next i

I have researched the problem and think that something like the following would be more efficient:

VBA Code: 
b = ThisWorkbook.Sheets("Data").Range("A1").End(xlDown).Row + 1

The problem is that I don't know how to integrate this into the macro.

Can anyone help?

Many thanks


VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Columns.Count <> 16 Then Exit Sub

    Dim KeyCells As Range
    Set Target = ThisWorkbook.Worksheets("Sheet1").Range("F2")
' The variable KeyCells contains the cells that will
    ' cause an alert when they are changed.
    Set KeyCells = ThisWorkbook.Worksheets("Sheet1").Range("A1:P50")
    
    'If ThisWorkbook.Worksheets("Sheet1").Range("F2") = "Closed" And ThisWorkbook.Worksheets("Sheet1").Range("Q2") <> -5 Then
    'ThisWorkbook.Worksheets("Sheet1").Range("Q2").Value = 30
    'End If
    
    'If ThisWorkbook.Worksheets("Sheet1").Range("E2") = "Not In Play" And ThisWorkbook.Worksheets("Sheet1").Range("F2") = "" And ThisWorkbook.Worksheets("Sheet1").Range("AA5").Value > 350 Then
    'ThisWorkbook.Worksheets("Sheet1").Range("Q2").Value = 30
    'End If
    
    'If ThisWorkbook.Worksheets("Sheet1").Range("E2") = "Not In Play" And ThisWorkbook.Worksheets("Sheet1").Range("F2") = "" And ThisWorkbook.Worksheets("Sheet1").Range("AA5").Value < 350 Then
    'ThisWorkbook.Worksheets("Sheet1").Range("Q2").Value = 1
    'End If
    
    'If ThisWorkbook.Worksheets("Sheet1").Range("E2") = "In Play" And ThisWorkbook.Worksheets("Sheet1").Range("F2") = "" Then
    'ThisWorkbook.Worksheets("Sheet1").Range("Q2").Value = 1
    'End If

If Not Application.Intersect(KeyCells, Range(Target.Address)) _
           Is Nothing Then
           
'Count the cells to copy
Dim a As Integer
a = 0
For i = 5 To 12
If ThisWorkbook.Sheets("Sheet1").Cells(i, 1) <> "" Then
a = a + 1
End If
Next i

'Count the last cell where to start copying
Dim b As Long
b = 2
For i = 2 To 100000
If ThisWorkbook.Sheets("Data").Cells(i, 1) <> "" Then
b = b + 1
End If
Next i

Dim c As Integer
c = 5
'Perform the copy paste process
Application.EnableEvents = False
For i = b To b + a - 1

If ThisWorkbook.Worksheets("Sheet1").Range("E2") <> "" And ThisWorkbook.Worksheets("Sheet1").Range("F2") = "" And ThisWorkbook.Worksheets("Sheet1").Range("AB5") = "35" Then
ThisWorkbook.Sheets("Data").Cells(i, 1) = ThisWorkbook.Sheets("Sheet1").Cells(3, 14)
ThisWorkbook.Sheets("Data").Cells(i, 2) = ThisWorkbook.Sheets("Sheet1").Cells(2, 2)
ThisWorkbook.Sheets("Data").Cells(i, 3) = ThisWorkbook.Sheets("Sheet1").Cells(1, 1)
ThisWorkbook.Sheets("Data").Cells(i, 4) = ThisWorkbook.Sheets("Sheet1").Cells(2, 5)
ThisWorkbook.Sheets("Data").Cells(i, 5) = ThisWorkbook.Sheets("Sheet1").Cells(c, 26)
ThisWorkbook.Sheets("Data").Cells(i, 6) = ThisWorkbook.Sheets("Sheet1").Cells(c, 1)
ThisWorkbook.Sheets("Data").Cells(i, 7) = ThisWorkbook.Sheets("Sheet1").Cells(c, 6)
ThisWorkbook.Sheets("Data").Cells(i, 8) = ThisWorkbook.Sheets("Sheet1").Cells(c, 8)
ThisWorkbook.Sheets("Data").Cells(i, 9) = ThisWorkbook.Sheets("Sheet1").Cells(c, 15)
ThisWorkbook.Sheets("Data").Cells(i, 10) = ThisWorkbook.Sheets("Sheet1").Cells(c, 16)
ThisWorkbook.Sheets("Data").Cells(i, 11) = ThisWorkbook.Sheets("Sheet1").Cells(3, 2)
ThisWorkbook.Sheets("Data").Cells(i, 12) = ThisWorkbook.Sheets("Sheet1").Cells(c, 7)
ThisWorkbook.Sheets("Data").Cells(i, 13) = ThisWorkbook.Sheets("Sheet1").Cells(c, 2)
ThisWorkbook.Sheets("Data").Cells(i, 14) = ThisWorkbook.Sheets("Sheet1").Cells(c, 3)
ThisWorkbook.Sheets("Data").Cells(i, 15) = ThisWorkbook.Sheets("Sheet1").Cells(c, 4)
ThisWorkbook.Sheets("Data").Cells(i, 16) = ThisWorkbook.Sheets("Sheet1").Cells(c, 5)
ThisWorkbook.Sheets("Data").Cells(i, 17) = ThisWorkbook.Sheets("Sheet1").Cells(c, 9)
ThisWorkbook.Sheets("Data").Cells(i, 18) = ThisWorkbook.Sheets("Sheet1").Cells(c, 12)
ThisWorkbook.Sheets("Data").Cells(i, 19) = ThisWorkbook.Sheets("Sheet1").Cells(c, 13)
ThisWorkbook.Sheets("Data").Cells(i, 20) = ThisWorkbook.Sheets("Sheet1").Cells(c, 10)
ThisWorkbook.Sheets("Data").Cells(i, 21) = ThisWorkbook.Sheets("Sheet1").Cells(c, 11)
ThisWorkbook.Sheets("Data").Cells(i, 22) = ThisWorkbook.Sheets("Sheet1").Cells(c, 25)

c = c + 1
End If
Next i
Application.EnableEvents = True

End If


End Sub
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Sort by date Sort by votes
delete this code:
VBA Code: 
'Count the last cell where to start copying
Dim b As Long
b = 2
For i = 2 To 100000
If ThisWorkbook.Sheets("Data").Cells(i, 1) <> "" Then
b = b + 1
End If
Next i
and use your one line instead or the line that I use is:
VBA Code: 
b = Cells(Rows.Count, "A").End(xlUp).Row

Note there are lots of other things in your code do to speed up your code , which since it is on worksheet change is worth doing
The really slow thing in vba is accessing the workhseet so every access takes valuable time.
So use the same code on your Sheet1 and change the sheet name
 
Upvote 0
I have found some time to do a bit more work on this:
One of the main reasons that Vba is slow is the time taken to access the worksheet from VBa is a relatively long time.
To speed up vba the easiest way is to minimise the number of accesses to the worksheet. What is interesting is that the time taken to access a single cell on the worksheet in vba is almost identical as the time taken to access a large range if it is done in one action.

So instead of writing a loop which loops down a range copying one row at a time which will take along time if you have got 50000 rows it is much quicker to load the 50000 lines into a variant array ( one worksheet access), then copy the lines to a variant array and then write the array back to the worksheet, ( one worksheet access for each search that you are doing),

I have a simple rule for fast VBA: NEVER ACCESS THE WORKSHEET IN A LOOP.
I have rewritten your code using a variant array for the inputs and a variant array for the outputs so this code should be at least 1000 times faster than yours, it is untested so I hope it works, so try it on copy of your workbook
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Columns.Count <> 16 Then Exit Sub

    Dim KeyCells As Range
    Set Target = ThisWorkbook.Worksheets("Sheet1").Range("F2")
' The variable KeyCells contains the cells that will
    ' cause an alert when they are changed.
    Set KeyCells = ThisWorkbook.Worksheets("Sheet1").Range("A1:P50")
  
    'If ThisWorkbook.Worksheets("Sheet1").Range("F2") = "Closed" And ThisWorkbook.Worksheets("Sheet1").Range("Q2") <> -5 Then
    'ThisWorkbook.Worksheets("Sheet1").Range("Q2").Value = 30
    'End If
  
    'If ThisWorkbook.Worksheets("Sheet1").Range("E2") = "Not In Play" And ThisWorkbook.Worksheets("Sheet1").Range("F2") = "" And ThisWorkbook.Worksheets("Sheet1").Range("AA5").Value > 350 Then
    'ThisWorkbook.Worksheets("Sheet1").Range("Q2").Value = 30
    'End If
  
    'If ThisWorkbook.Worksheets("Sheet1").Range("E2") = "Not In Play" And ThisWorkbook.Worksheets("Sheet1").Range("F2") = "" And ThisWorkbook.Worksheets("Sheet1").Range("AA5").Value < 350 Then
    'ThisWorkbook.Worksheets("Sheet1").Range("Q2").Value = 1
    'End If
  
    'If ThisWorkbook.Worksheets("Sheet1").Range("E2") = "In Play" And ThisWorkbook.Worksheets("Sheet1").Range("F2") = "" Then
    'ThisWorkbook.Worksheets("Sheet1").Range("Q2").Value = 1
    'End If

If Not Application.Intersect(KeyCells, Range(Target.Address)) _
           Is Nothing Then
         
'Count the cells to copy
Dim a As Integer
With Worksheets("Sheet1")
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
inarr = .Range(.Cells(1, 1), .Cells(lastrow, 26)) ' load all of sheet 1 data in a variant array
End With
a = lastrow
'Count the last cell where to start copying
Dim b As Long

With Worksheets("Data")
b =.Cells(Rows.Count, "A").End(xlUp).Row


Dim c As Integer
c = 5
'Perform the copy paste process
Dim outarr() As Variant
ReDim outarr(1 To a, 1 To 22)
Application.EnableEvents = False
For i = 1 To a - 1

If ThisWorkbook.Worksheets("Sheet1").Range("E2") <> "" And ThisWorkbook.Worksheets("Sheet1").Range("F2") = "" And ThisWorkbook.Worksheets("Sheet1").Range("AB5") = "35" Then
outarr(i, 1) = inarr(3, 14)
outarr(i, 2) = inarr(2, 2)
outarr(i, 3) = inarr(1, 1)
outarr(i, 4) = inarr(2, 5)
outarr(i, 5) = inarr(c, 26)
outarr(i, 6) = inarr(c, 1)
outarr(i, 7) = inarr(c, 6)
outarr(i, 8) = inarr(c, 8)
outarr(i, 9) = inarr(c, 15)
outarr(i, 10) = inarr(c, 16)
outarr(i, 11) = inarr(3, 2)
outarr(i, 12) = inarr(c, 7)
outarr(i, 13) = inarr(c, 2)
outarr(i, 14) = inarr(c, 3)
outarr(i, 15) = inarr(c, 4)
outarr(i, 16) = inarr(c, 5)
outarr(i, 17) = inarr(c, 9)
outarr(i, 18) = inarr(c, 12)
outarr(i, 19) = inarr(c, 13)
outarr(i, 20) = inarr(c, 10)
outarr(i, 21) = inarr(c, 11)
outarr(i, 22) = inarr(c, 25)

c = c + 1
End If
Next i
.Range(.Cells(b + 1, 1), .Cells(b + 1 + a, 22)) = outarr
End With
Application.EnableEvents = True

End If


End Sub
 
Upvote 0
Thanks offthelip, this goes above and beyond. I have tried it out. It seems to ignore the
VBA Code: 
ThisWorkbook.Worksheets("Sheet1").Range("AB5") = "35"
condition and starts pasting even when AB5 is not 35 (it is either empty or contains 35). It also gives a "run-time error 9 subscript out of range" error on this
VBA Code: 
outarr(i, 5) = inarr(c, 26)
and subsequent outarr lines. Do you have any idea what the issue is?

Thanks again
 
Upvote 0
I didn't change the line testing AB5 or your control of c in the loop, so I have no idea why that is happening
to try and get something out of the code I suggest changing this line:
VBA Code: 
inarr = .Range(.Cells(1, 1), .Cells(lastrow, 26)) ' load all of sheet 1 data in a variant array
to
VBA Code: 
inarr = .Range(.Cells(1, 1), .Cells(lastrow+5, 26)) ' load all of sheet 1 data in a variant array
Hopefully this will get rid of the error but is probably not the final solution.
Can you check what the value in a, i and C is if it does throw an error..
Note it shouldn't be pasting anything until is has completed the loop
 
Upvote 0
I have just noticed in your code above where I was looking that you have got this line:
VBA Code: 
   Set Target = ThisWorkbook.Worksheets("Sheet1").Range("F2")
This seems a very strange thing to do in a worksheet change event code , can you explain what you are trying to do??
 
Upvote 0
Hi offthelip, thanks for this. The new line gets rid of the error however it still ignores the AB5 condition and there are 10 blank rows followed by a row of #N/As before each paste operation.

I don't know what the Set Target line is intended to do. I inherited the sheet but can't see why it would be needed.
 
Upvote 0
Does it paste any information?? does it paste the correct information just in the wrong place? Does it paste only some of the correct information ?? How many rows of #N/As are there??
All your code at the top of your module seems a bit strange :
this line will prevent the sub running most of the tiime:
VBA Code: 
If Target.Columns.Count <> 16 Then Exit Sub
Do you need that?
I suggest you delete this line

VBA Code: 
    Set Target = ThisWorkbook.Worksheets("Sheet1").Range("F2")
 
Upvote 0
Hi offthelip, thanks. The Target.Columns.Count is necessary because the software doesn't refresh everything in one go. Without this line the macro would run more than once for each refresh. The 16 makes sure that the macro only runs after the 'main' data changes.

I have deleted the line suggested and the macro is doing the following:

When there is no 35 in cell AB5 it pastes 10 blank rows followed by a row of #N/As.

When there is 35 in AB5 it pastes the data but also includes a blank row, a row of #N/As and some additional data (eg rows 62-64 and 75-77). I've uploaded the sheet here: Testv6.xlsm
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question
VBA compare values on different sheets.
Replies
5
Views
98
rlv01
R
G
  • Question
VB Issue pulling data with date specific
Replies
4
Views
124
Trevor G
Trevor G
A
  • Solved
VBA Help!
Replies
2
Views
96
AusNewb
A
J
  • Question
VBA Script - Can't figure out one error...
2
Replies
15
Views
314
Peter_SSs
Peter_SSs
J
  • Question
VBA Macros running slow out of nowhere
Replies
3
Views
295
mumps
mumps

Forum statistics

Threads
1,215,733
Messages
6,126,541
Members
449,316
Latest member
sravya

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