Combining 2 Change Event Macros

A

andybason

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

I have 2 change event macros that I want to combine. Wherever I add the 2nd macro it does not trigger.

Can anyone show me where it should go?

Thanks

Current change event macro:

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 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 50
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 Integer
b = 2
For i = 2 To 50000
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") = "10" 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, 25)
ThisWorkbook.Sheets("Data").Cells(i, 13) = ThisWorkbook.Sheets("Sheet1").Cells(c, 7)
ThisWorkbook.Sheets("Data").Cells(i, 14) = ThisWorkbook.Sheets("Sheet1").Cells(c, 2)
ThisWorkbook.Sheets("Data").Cells(i, 15) = ThisWorkbook.Sheets("Sheet1").Cells(c, 3)
ThisWorkbook.Sheets("Data").Cells(i, 16) = ThisWorkbook.Sheets("Sheet1").Cells(c, 4)
ThisWorkbook.Sheets("Data").Cells(i, 17) = ThisWorkbook.Sheets("Sheet1").Cells(c, 5)
ThisWorkbook.Sheets("Data").Cells(i, 18) = ThisWorkbook.Sheets("Sheet1").Cells(c, 9)
ThisWorkbook.Sheets("Data").Cells(i, 19) = ThisWorkbook.Sheets("Sheet1").Cells(c, 12)
ThisWorkbook.Sheets("Data").Cells(i, 20) = ThisWorkbook.Sheets("Sheet1").Cells(c, 13)
ThisWorkbook.Sheets("Data").Cells(i, 21) = ThisWorkbook.Sheets("Sheet1").Cells(c, 10)
ThisWorkbook.Sheets("Data").Cells(i, 22) = ThisWorkbook.Sheets("Sheet1").Cells(c, 11)

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

End If

Dim lastcell As Range
    Dim wsStore As Worksheet
    
    Set wsStore = ThisWorkbook.Worksheets("Store")
    
    Set lastcell = wsStore.Cells(wsStore.Rows.Count, 1).End(xlUp)
    
    With ThisWorkbook.Worksheets("Sheet1").Range("F2")
're-set F2 when last cell of the Store sheet is no longer the same as the value in N3
    If .Value = "Closed" And Val(.ID) <> xlOff Then
    .ID = xlOff
        
    Call CopyToStore
    Call ClearData
        
        ElseIf .Offset(1, 8).Value <> lastcell.Value Then
            .ID = xlOn
        End If
    End With

End Sub

2nd macro:

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False

    If ThisWorkbook.Worksheets("Sheet1").Range("F2") = "Closed" 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") = "" 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 = 0.2
    End If
    
Application.EnableEvents = True
End Sub
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
Sort by date Sort by votes
Try this

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim wb As Workbook, data As Worksheet, ws1 As Worksheet
    Set wb = ThisWorkbook
    Set data = wb.Sheets("Data")
    Set ws1 = wb.Sheets("Sheet1")

Application.EnableEvents = False
    If ws1.Range("F2") = "Closed" Then ws1.Range("Q2").Value = 30
    If ws1.Range("E2") = "Not In Play" And ws1.Range("F2") = "" Then ws1.Range("Q2").Value = 1
    If ws1.Range("E2") = "In Play" And ws1.Range("F2") = "" Then ws1.Range("Q2").Value = 0.2
Application.EnableEvents = True

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

    Dim KeyCells As Range
    Set Target = ws1.Range("F2")
' The variable KeyCells contains the cells that will
    ' cause an alert when they are changed.
    Set KeyCells = ws1.Range("A1:P50")

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 50
    If ws1.Cells(i, 1) <> "" Then a = a + 1
Next i

'Count the last cell where to start copying
Dim b As Integer
b = 2
For i = 2 To 50000
    If data.Cells(i, 1) <> "" Then b = b + 1
Next i

Dim c As Integer
c = 5
'Perform the copy paste process
Application.EnableEvents = False
For i = b To b + a - 1
    If ws1.Range("E2") <> "" And ws1.Range("F2") = "" And ws1.Range("AB5") = "10" Then
        data.Cells(i, 1) = ws1.Cells(3, 14)
        data.Cells(i, 2) = ws1.Cells(2, 2)
        data.Cells(i, 3) = ws1.Cells(1, 1)
        data.Cells(i, 4) = ws1.Cells(2, 5)
        data.Cells(i, 5) = ws1.Cells(c, 26)
        data.Cells(i, 6) = ws1.Cells(c, 1)
        data.Cells(i, 7) = ws1.Cells(c, 6)
        data.Cells(i, 8) = ws1.Cells(c, 8)
        data.Cells(i, 9) = ws1.Cells(c, 15)
        data.Cells(i, 10) = ws1.Cells(c, 16)
        data.Cells(i, 11) = ws1.Cells(3, 2)
        data.Cells(i, 12) = ws1.Cells(c, 25)
        data.Cells(i, 13) = ws1.Cells(c, 7)
        data.Cells(i, 14) = ws1.Cells(c, 2)
        data.Cells(i, 15) = ws1.Cells(c, 3)
        data.Cells(i, 16) = ws1.Cells(c, 4)
        data.Cells(i, 17) = ws1.Cells(c, 5)
        data.Cells(i, 18) = ws1.Cells(c, 9)
        data.Cells(i, 19) = ws1.Cells(c, 12)
        data.Cells(i, 20) = ws1.Cells(c, 13)
        data.Cells(i, 21) = ws1.Cells(c, 10)
        data.Cells(i, 22) = ws1.Cells(c, 11)
        
        c = c + 1
    End If
Next i
Application.EnableEvents = True

End If

    Dim lastcell As Range
    Dim wsStore As Worksheet
    
    Set wsStore = wb.Worksheets("Store")
    Set lastcell = wsStore.Cells(wsStore.Rows.Count, 1).End(xlUp)
    
    With ws1.Range("F2")
're-set F2 when last cell of the Store sheet is no longer the same as the value in N3
    If .Value = "Closed" And Val(.ID) <> xlOff Then
    .ID = xlOff
        
    Call CopyToStore
    Call ClearData
        
        ElseIf .Offset(1, 8).Value <> lastcell.Value Then
            .ID = xlOn
        End If
    End With
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question
VBA Macros running slow out of nowhere
Replies
3
Views
198
mumps
mumps
J
  • Question
VBA Script - Can't figure out one error...
2
Replies
15
Views
209
Peter_SSs
Peter_SSs
A
  • Question
Macro Maxing Out CPU
2
Replies
11
Views
598
andybason
A
Y
  • Solved
Highlighting selected words in a column.
Replies
6
Views
132
Akuini
Akuini
P
  • Question
Code used for comparison between 2 list.
Replies
3
Views
298
Tupe77
T

Forum statistics

Threads
1,214,655
Messages
6,120,760
Members
448,991
Latest member
Hanakoro

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