Combining 2 Change Event Macros

andybason

Board Regular
Joined
Jan 7, 2012
Messages
180
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

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,977
Office Version
  1. 365
Platform
  1. Windows
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
 

Watch MrExcel Video

Forum statistics

Threads
1,129,940
Messages
5,639,099
Members
417,072
Latest member
JaimeDee

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
Top