VBA change event code

J

jamescooper

Well-known Member
Joined
Sep 8, 2014
Messages
840
I have the following code which tracks changes to cells in the appropriate columns.

Code: 
Private Sub Worksheet_Calculate()


nR = Cells(Rows.Count, "AG").End(xlUp).Row + 1
nR2 = Cells(Rows.Count, "AK").End(xlUp).Row + 1
nR3 = Cells(Rows.Count, "AO").End(xlUp).Row + 1
nR4 = Cells(Rows.Count, "AS").End(xlUp).Row + 1
nR5 = Cells(Rows.Count, "AW").End(xlUp).Row + 1
nR6 = Cells(Rows.Count, "BA").End(xlUp).Row + 1


inarr0 = Range("H1")
inarr = Range("K9:K10")
inarr2 = Range("K11:K12")
inarr3 = Range("K13:K14")
inarr4 = Range("K15:K16")
inarr5 = Range("K17:K18")
inarr6 = Range("K19:K20")


If inarr(1, 1) <> oldk9 Or inarr(2, 1) <> oldk10 Then


Application.EnableEvents = False


Range("AH" & nR) = inarr(1, 1)
Range("AI" & nR) = inarr(2, 1)
oldk9 = inarr(1, 1)
oldk10 = inarr(2, 1)
Sheets("Bet Angel").Range("F4").Copy Destination:=Sheets("Sheet1").Range("AG" & nR)


Application.EnableEvents = True


End If

End Sub

I now want to add the following code which copies to another sheet when cell H1 says "Suspended". This works but then it continues to do this over and over and I only want it to do it once? Any ideas? Many thanks.

Code: 
 If Range("H1") = "Suspended" Then
        Range("AG1:BC1000").Copy Sheets("Data").Cells(Sheets("Data").Rows.Count, "B").End(xlUp).Offset(1, 0)
 
Sort by date Sort by votes
Have added inarr0 to module 1.

I now receive runtime error 13 message on the following line:

Code: 
If inarr0(1, 1) <> "Suspended" And Range("H1") = "Suspended" Then

Thanks.
​
 
Upvote 0

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop
Can you post all of the declarations you have got in module 1 and code in the worksheet_calculate subroutine.
 
Upvote 0
Module 1:

Code: 
Public oldh1
Public inarr0
Public oldk9
Public oldk10
Public oldk11
Public oldk12
Public oldk13
Public oldk14
Public oldk15
Public oldk16
Public oldk17
Public oldk18
Public oldk19
Public oldk20


Sub test()


End Sub

Code: 
Private Sub Worksheet_Calculate()


nR = Cells(Rows.Count, "AG").End(xlUp).Row + 1
nR2 = Cells(Rows.Count, "AK").End(xlUp).Row + 1
nR3 = Cells(Rows.Count, "AO").End(xlUp).Row + 1
nR4 = Cells(Rows.Count, "AS").End(xlUp).Row + 1
nR5 = Cells(Rows.Count, "AW").End(xlUp).Row + 1
nR6 = Cells(Rows.Count, "BA").End(xlUp).Row + 1


inarr = Range("K9:K10")
inarr2 = Range("K11:K12")
inarr3 = Range("K13:K14")
inarr4 = Range("K15:K16")
inarr5 = Range("K17:K18")
inarr6 = Range("K19:K20")


If inarr(1, 1) <> oldk9 Or inarr(2, 1) <> oldk10 Then


Application.EnableEvents = False


Range("AH" & nR) = inarr(1, 1)
Range("AI" & nR) = inarr(2, 1)
oldk9 = inarr(1, 1)
oldk10 = inarr(2, 1)
Sheets("Sheet1").Range("F4").Copy Destination:=Sheets("Sheet1").Range("AG" & nR)


Application.EnableEvents = True


End If


If inarr2(1, 1) <> oldk11 Or inarr2(2, 1) <> oldk12 Then


Application.EnableEvents = False


Range("AL" & nR2) = inarr2(1, 1)
Range("AM" & nR2) = inarr2(2, 1)
oldk11 = inarr2(1, 1)
oldk12 = inarr2(2, 1)
Sheets("Sheet1").Range("F4").Copy Destination:=Sheets("Sheet1").Range("AK" & nR2)


Application.EnableEvents = True


End If


If inarr3(1, 1) <> oldk13 Or inarr3(2, 1) <> oldk14 Then


Application.EnableEvents = False


Range("AP" & nR3) = inarr3(1, 1)
Range("AQ" & nR3) = inarr3(2, 1)
oldk13 = inarr3(1, 1)
oldk14 = inarr3(2, 1)
Sheets("Sheet1").Range("F4").Copy Destination:=Sheets("Sheet1").Range("AO" & nR3)


Application.EnableEvents = True


End If


If inarr4(1, 1) <> oldk15 Or inarr4(2, 1) <> oldk16 Then


Application.EnableEvents = False


Range("AT" & nR4) = inarr4(1, 1)
Range("AU" & nR4) = inarr4(2, 1)
oldk15 = inarr4(1, 1)
oldk16 = inarr4(2, 1)
Sheets("Sheet1").Range("F4").Copy Destination:=Sheets("Sheet1").Range("AS" & nR4)


Application.EnableEvents = True


End If


If inarr5(1, 1) <> oldk17 Or inarr5(2, 1) <> oldk18 Then


Application.EnableEvents = False


Range("AX" & nR5) = inarr5(1, 1)
Range("AY" & nR5) = inarr5(2, 1)
oldk17 = inarr5(1, 1)
oldk18 = inarr5(2, 1)
Sheets("Sheet1").Range("F4").Copy Destination:=Sheets("Sheet1").Range("AW" & nR5)


Application.EnableEvents = True


End If


If inarr6(1, 1) <> oldk19 Or inarr6(2, 1) <> oldk20 Then


Application.EnableEvents = False


Range("BB" & nR6) = inarr6(1, 1)
Range("BC" & nR6) = inarr6(2, 1)
oldk19 = inarr6(1, 1)
oldk20 = inarr6(2, 1)
Sheets("Sheet1").Range("F4").Copy Destination:=Sheets("Sheet1").Range("BA" & nR6)


Application.EnableEvents = True


End If


If inarr0(1, 1) <> "Suspended" And Range("H1") = "Suspended" Then


Application.EnableEvents = False


Range("AG1:BC1000").Copy Sheets("Data").Cells(Sheets("Data").Rows.Count, "B").End(xlUp).Offset(1, 0)


End If


inarr0 = Range("H1")


Application.EnableEvents = True


End Sub
 
Upvote 0
thanks for posting that , I can see that your code is not written very efficiently which is particularly critical when the code is run everytime the worksheet recalculates. This will make your worksheet slow, which if you are downloading realtime data could be a problem. 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 I have rewritten you routine reducing the accesses to the worksheet which should make it run faster and be easier to maintain. to do this rather than duplicating code and changing the address we do everything in a loop of 6, The addresses you are using allows this because they move either two rows at a time or 4 columns at a time. I load all the data into a variant array and also use an array to store the previous values
So can I suggest you try this code which should do everything that you currently have in yours. although I haven't tested it at all, but it should be a bit faster than yours.
In module 1
Code: 
Public inarr0

Public oldvals(1 To 12, 1 To 1) As Variant


Sub test()


End Sub
In the worksheet:
Code: 
Private Sub Worksheet_Calculate()

' load all the inputs into an array
inarr = Range("K9:K20")
' loop round the 6 inputs stepping two rows at a time
For i = 1 To 12 Step 2
 If inarr(i, 1) <> oldvals(i, 1) Or inarr(i + 1, 1) <> oldvals(i + 1, 1) Then
 'Latest input are different from last time, so copy the data
 ' note the 33+(i-1)*2 should give values of 33 ,37,41,45 which are columns AG,AK,AO etc
   nr = Cells(Rows.Count, 33 + (i - 1) * 2).End(xlUp).Row + 1
   Application.EnableEvents = False
 ' note the 34+(i-1)*2 should give values of 34 ,38,42,44 which are columns AH,AL,AP etc
 ' 35 wil lgive the next column
    'copy data
    Range(Cells(nr, 34 + (i - 1) * 2), Cells(nr, 34 + (i - 1) * 2)) = inarr(i, 1)
    Range(Cells(nr, 35 + (i - 1) * 2), Cells(nr, 35 + (i - 1) * 2)) = inarr(i + 1, 1)
    ' update old values with the latest
    oldvals(i, 1) = inarr(i, 1)
    oldvals(i + 1, 1) = inarr(i + 1, 1)
    ' copy f4 across
    Sheets("Sheet1").Range("F4").Copy Destination:=Sheets("Sheet1").Range(Cells(nr, 34 + (i - 1) * 2), Cells(nr, 34 + (i - 1) * 2))
 End If






If inarr0 <> "Suspended" And Range("H1") = "Suspended" Then
Application.EnableEvents = False
Range("AG1:BC1000").Copy Sheets("Data").Cells(Sheets("Data").Rows.Count, "B").End(xlUp).Offset(1, 0)
End If
' update old values with the latest


inarr0 = Range("H1")


Application.EnableEvents = True
End Sub

I have put comments in the code to try and explain what is going on. Try to understand how it is supposed to work , then you will get better at trying to debug it when it falls over ( which it probably will because I haven't tested it)
 
Last edited:
Upvote 0
Thank you for the detail above, I think a next at the end.

It is sort of working but 2 clear errors:

The first column in each set AG, AK, AO, AS, AW and BA are not copying across.

And secondly, it is copy and pasting over the previous rather than adding below when a change happens in the array K9/K10, K11/K12 etc...

Thanks so far though.
 
Upvote 0
I can see why both of the error are occurring it is because I copied what your code was doing!! :
in your code you detect the last row looking at row AG:
Code: 
nR = Cells(Rows.Count, "AG").End(xlUp).Row + 1
but in the code you are copying to columns H and I
Code: 
Range("AH" & nR) = inarr(1, 1)
Range("AI" & nR) = inarr(2, 1)

So change this:
Code: 
nr = Cells(Rows.Count, 33 + (i - 1) * 2).End(xlUp).Row + 1
to
Code: 
nr = Cells(Rows.Count, 34 + (i - 1) * 2).End(xlUp).Row + 1

and it might solve both problems
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question Question
Copy and unfilter in VBA
Replies
1
Views
183
Alex Blakenburg
A
J
  • Question Question
Copying Rows Based on Column Value
Replies
1
Views
181
jolivanes
jolivanes
Q
  • Solved
Excel existing code flaw
2
Replies
11
Views
241
MARK858
MARK858
S
  • Solved
Undo is greyed out
Replies
7
Views
2K
sspatriots
S
F
  • Question Question
VBA Code to record changes/logs modification needed?
Replies
0
Views
394
FGaxha
F

Forum statistics

Threads
1,224,827
Messages
6,181,197
Members
453,021
Latest member
pingpong7117

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