Ayuda macro

No se si es esto exactamente lo que quieres pero prueba a crear un nuevo modulo y copiar esto:
Public Nombre, Dia, Numero, Num2
Sub Dias()
    Cells(2, 1).Select
    Do While Not IsEmpty(ActiveCell)
        Nombre = ActiveCell.Value
        Dia = Cells(ActiveCell.Row, 2)
        Numero = Cells(ActiveCell.Row, 3)
        Num2 = Cells(ActiveCell.Row, 4)
        ActiveCell.Offset(1#).Select
        mail
    Loop
End Sub
Sub mail()
Dim Correo As Object
Dim Mensaje As Object
Set Correo = CreateObject("Outlook.Application")
Set Mensaje = Correo.CreateItem(0)
With Mensaje
.Subject = "Asunto animales" & Nombre ' Pon el encabezado que quieras
.Body = "Sr(a) " & Nombre & Chr(10) & Chr(10) & _
"le informo a usted que el dia " & Dia & ", el N°" & Numero & ", y el " & _
Num2 & "." & Chr(10) & Chr(10) & "gracias." ' pon el mensaje que quieras
Mensaje.To = [email protected] ' pon el correo electronico que quieras
Mensaje.Send
End With
End Sub
Bien tienes que ejecutar Días, este lo que hace es ir a la primera fila que le diga y coge los datos de las columnas 1,2,3 y 4. Y los utiliza para enviar un mensaje, lo manda y luego vuelve a la siguiente fila.
Creo que es esto lo que querías. Si no comentame algo

Gracias por tu aclaración, muy buen aporte.

De nada, si ya está todo finaliza la pregunta

Cuando la termine, finalizo

Mira, este código hace que me agregue los datos:
Public Nombre, Dia, Numero, Num2
Sub Dias()
    Cells(2, 8).Select
    Do While Not IsEmpty(ActiveCell)
        Nombre = ActiveCell.Value
        Dia = Cells(ActiveCell.Row, 11)
        Numero = Cells(ActiveCell.Row, 1)
        Num2 = Cells(ActiveCell.Row, 2)
        ActiveCell.Offset(1#).Select
        mail
    Loop
End Sub
Sub mail()
Dim Correo As Object
Dim Mensaje As Object
Set Correo = CreateObject("Outlook.Application")
Set Mensaje = Correo.CreateItem(0)
With Mensaje
.Subject = "Asunto animales" & Nombre
.Body = "Sr(a) " & Nombre & Chr(10) & Chr(10) & _
"le informo a usted que el dia " & Dia & ", el N°" & Numero & ", y el " & _
Num2 & "." & Chr(10) & Chr(10) & "gracias."
Mensaje.To = "(xxxxxx)"
Mensaje.Send
End With
End Sub
Pero no se como agregarlo a mi macro original, me puedes ayudar?
Sub SendMail()
   Dim objOutlook As Object
   Dim objMail As Object
   Dim objOutlookAttach As Object
   Cells(2, 2).Select
   Do While Not IsEmpty(ActiveCell)
        Dim x As String
        x = ActiveCell.Value
        cel = ActiveCell.Address
        Call lateral(x)
        Range(cel).Select
        ActiveCell.Offset(1, 0).Select
     Loop
   Set objMail = Nothing
   Set objOutlook = Nothing
End Sub
Sub lateral(x)
    Dim objOutlook2 As Object
    Dim objMail2 As Object
    Dim objOutlookAttach2 As Object
    Dim cont As Integer
    Dim cadena As String
    cadena = ";"
    cont = 0
    For i = 0 To 10000
        ActiveCell.Offset(0, 1).Select
        If (ActiveCell.Value = "") Then
            cont = cont + 1
            If (cont > 5) Then
                i = 10000
            End If
        Else
            Dim p As String
            p = ActiveCell.Value
            If (ActiveCell.Value <> "") Then
                cadena = p & ";" & cadena
            End If
        End If
    Next
    cadena = cadena & x
    Set objOutlook2 = CreateObject("Outlook.Application")
    Set objMail2 = objOutlook2.CreateItem(olMailItem)
    Set objOutlookAttach2 = objOutlook2.CreateItem(olAttachMents)
      With objMail2
         .To = cadena
         .Subject = "prueba"
         .Body = ""Sr(a) " & Nombre & Chr(10) & Chr(10) & _
"le informo a usted que el dia " & Dia & ", el N°" & Numero & ", y el " & _
Num2 & "." & Chr(10) & Chr(10) & "gracias."
         .Send
    End With
            Set objMail = Nothing
            Set objOutlook = Nothing
End Sub
Por favor me puedes ayudar a unir los 2 códigos.