Macro Maxing Out CPU

[andybason]

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:

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

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

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

 

[offthelip]

to get rid of the #N/A change this line:

.Range(.Cells(b + 1, 1), .Cells(b + 1 + a, 22)) = outarr

to

ThisWorkbook.Worksheets("Data").Range(.Cells(b + 1, 1), .Cells(b + a, 22)) = outarr

I have checked my code and it is doing exactly what I expected and is working correctly once you have made the above modfication. The other problems you have got are to do with how you a triggering the code, which is combined with the code you have got in the worksheet calculate event. This is an entirely different probelm to causing your cpu to max out. That problem is solved by my code. Unfortunately I don't have time to solve your triggering problem so I suggest you start a new thread to solve that problem.

 

[andybason]

Thanks for all the help. It is really appreciated.