Sub Macro not working with main Macro

I am trying to run sub macro after the main macro has executed but it is not running , this macro is regarding mail sending from excel to lotus notes but at a time only one mail is going , i wanted all the email within that column one by one should get executed , kindly let me know what i have to change as i am new to VBA

Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long

Sub SendEMail1()
Dim Email As String, Subj As String
Dim Msg As String, URL As String
Dim r As Integer, x As Double
r = ActiveCell.Row
'Get the email address
Email = Cells(r, 10) & ";" & Cells(r, 11)

'Message subject
Subj = Cells(r, 17)

'Compose the message
Msg = ""
Msg = Msg & Cells(r, 19) & "," & vbCrLf & vbCrLf

'Replace spaces with %20 (hex)
Subj = Application.WorksheetFunction.Substitute(Subj, " ", "%20")
Msg = Application.WorksheetFunction.Substitute(Msg, " ", "%20")

'Replace carriage returns with %0D%0A (hex)
Msg = Application.WorksheetFunction.Substitute(Msg, vbCrLf, "%0D%0A")

'Create the URL
URL = "mailto:" & Email & "?subject=" & Subj & "&body=" & Msg

'Execute the URL (start the email client)
ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus

'Wait two seconds before sending keystrokes
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%1"
End Sub
Sub Macro1()
'Sending all the email address which are in coloumn J & K
Dim nSheet As String, dateN As String
Dim x As Long, LRow As Long
Dim dateV As String
Dim CRT As Range, RNG As Range
nSheet = Sheets("sheet2").Name
dateV = Range("B2").Value
LRow = Cells(Rows.Count, "M").End(xlUp).Row
 
    Cells(Rows.Count, "A").End(xlUp).Offset(1, 28) = Range("M3")
    Cells(Rows.Count, "A").End(xlUp).Offset(1, 29) = Range("N3")
    Cells(Rows.Count, "A").End(xlUp).Offset(1, 30) = Range("O3")
    Cells(Rows.Count, "A").End(xlUp).Offset(2, 28) = Range("B2").Value
    Cells(Rows.Count, "A").End(xlUp).Offset(3, 29) = Range("B2").Value
    Cells(Rows.Count, "A").End(xlUp).Offset(4, 30) = Range("B2").Value
Set RNG = Sheets(nSheet).Range("A3:X" & LRow)
Set CRT = Sheets(nSheet).Cells(Rows.Count, "A").End(xlUp).Offset(1, 28).CurrentRegion
 
    CRT.Clear

End Sub

Can anyone help me out as i have to sent around 500 emails through excel