Duda para enviar mail cuando cambia celda

Hola buenas,

Tengo dudas con el siguiente archivo, cuando cambia una celda con lista desplegable a OK debería enviar un mail cuyo texto del body lo coge de una hoja4, hasta ahí todo bien, al hacer los cambios parece que funciona, aunque unas veces me deja el mail en blanco.

El problema viene que al hacer cambios en el resto de celdas se activa el envío de mail y, supuestamente la función indica claramente que se haga en una celda (aunque más adelante tendrá que valer para toda una columna). Esta es la función para la celda que llama a dos macros.

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'**Si celda cambia de texto en lista de verificación entonces ejecuto macro en modulo***'
If Range("q3") = "OK" Then Call correo Else
If Range("q3") = "DENEGADA" Then Call denied Else Exit Sub
End Sub

Macro correo

Sub correo()
'Macro para enviar correo tipo por negaciónd e cambio de fechas!!
Set dam1 = CreateObject("outlook.application")
Set dam2 = dam1.CreateItem(olMailItem)
dam2.To = "[email protected]" 'Destinatarios
dam2.Subject = "Solicitud de Cambio de Fechas" '"Asunto"
dam2.body = "Estimad@ estudiante," + G3
Range("Hoja2!H3").Copy
dam2.Display 'El correo se muestra
SendKeys "^{END}"
SendKeys "^v"
DoEvents
End Sub

Macro Denied

Sub denied()
'Macro para enviar correo tipo por negaciónd e cambio de fechas!!
 Set dam3 = CreateObject("outlook.application")
 Set dam4 = dam3.CreateItem(olMailItem)
 dam4.To = "[email protected]" 'Destinatarios
 dam4.Subject = "Solicitud de Cambio de Fechas" '"Asunto"
 dam4.body = "Estimad@ estudiante," + G3
 Range("Hoja2!H5").Copy
 dam4.Display 'El correo se muestra
 SendKeys "^{END}"
 SendKeys "^v"
 DoEvents
End Sub

Muchísimas graciasssss