Hi, the code below should allow you to send message alerts to WhatsApp numbers. Why is it not working you think?
Thanks have a nice day.
VBA Code:
Private Sub Envia_por_Numero_Click()
Dim RowCnt As Integer
Dim contact As String
Dim text As String
Dim movil As String
Dim fecha_recordatorio As Date, fecha_enviado As Date, presunto_envio As String
Dim BeginRow As Integer, LastRow As Integer
' Localiza la última fila con número de móvil
With ActiveSheet
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
BeginRow = 4
ActiveWorkbook.FollowHyperlink Address:="https://web.whatsapp.com/"
Application.Wait (Now + TimeValue("00:00:10"))
' Recorre la tabla y envía mensajes
For RowCnt = BeginRow To LastRow
' Primero comprueba que en la celda hay un número de móvil. Si está vacía salta a la siguiente fila
If IsEmpty(ActiveSheet.Cells(RowCnt, 2)) = False Then
movil = ActiveSheet.Cells(RowCnt, 2).Value
fecha_recordatorio = ActiveSheet.Cells(RowCnt, 3).Value
presunto_envio = ActiveSheet.Cells(RowCnt, 5).Value 'lo que contiene la fecha de "enviado"
' Comprueba que aún no se ha enviado el recordatorio (la celda de "fecha_enviado" contiene una fecha)
If IsEmpty(ActiveSheet.Cells(RowCnt, 5)) Or IsDate(presunto_envio) = False Then
' Hay que comprobar que por fecha hay que enviar el recordatorio y registrar la fecha de envio
If fecha_recordatorio <= Date Then
Call SendKeys("{TAB}", True) 'Posiciona cursor en campo "búsqueda"
Application.Wait (Now + TimeValue("00:00:02"))
Call SendKeys(movil, True)
Call SendKeys("~", True)
Application.Wait (Now + TimeValue("00:00:05"))
text = ActiveSheet.Cells(RowCnt, 4).Value
Call SendKeys(text, True)
Application.Wait (Now + TimeValue("00:00:2"))
Call SendKeys("~", True)
ActiveSheet.Cells(RowCnt, 5).Value = Date 'registra fecha de envio
Call SendKeys("{TAB}", True) 'Posiciona cursor en campo "búsqueda"
Application.Wait (Now + TimeValue("00:00:03"))
End If
End If
End If
Next RowCnt
End Sub
Private Sub Envia_mensajes_Click()
Dim RowCnt As Integer
Dim contact As String
Dim text As String
Dim movil As String
Dim fecha_recordatorio As Date, fecha_enviado As Date, presunto_envio As String
Dim BeginRow As Integer, LastRow As Integer
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
BeginRow = 4
ActiveWorkbook.FollowHyperlink Address:="https://web.whatsapp.com/"
Application.Wait (Now + TimeValue("00:00:10"))
' Recorre la tabla y envía mensajes
For RowCnt = BeginRow To LastRow
' Primero comprueba que en la celda hay un nombre. Si está vacía salta a la siguiente fila
If IsEmpty(ActiveSheet.Cells(RowCnt, 1)) = False Then
contact = ActiveSheet.Cells(RowCnt, 1).Value
fecha_recordatorio = ActiveSheet.Cells(RowCnt, 3).Value
presunto_envio = ActiveSheet.Cells(RowCnt, 5).Value 'lo que contiene la fecha de "enviado"
' Comprueba que aún no se ha enviado el recordatorio (la celda de "fecha_enviado" contiene una fecha)
If IsEmpty(ActiveSheet.Cells(RowCnt, 5)) Or IsDate(presunto_envio) = False Then
' Hay que comprobar que por fecha hay que enviar el recordatorio y registrar la fecha de envio
If fecha_recordatorio <= Date Then
Call SendKeys("{TAB}", True) 'Posiciona cursor en campo "búsqueda"
Application.Wait (Now + TimeValue("00:00:02"))
Call SendKeys(contact, True)
Call SendKeys("~", True)
Application.Wait (Now + TimeValue("00:00:02"))
text = ActiveSheet.Cells(RowCnt, 4).Value
Call SendKeys(text, True)
Application.Wait (Now + TimeValue("00:00:2"))
Call SendKeys("~", True)
ActiveSheet.Cells(RowCnt, 5).Value = Date 'registra fecha de envio
Call SendKeys("{TAB}", True) 'Posiciona cursor en campo "búsqueda"
Application.Wait (Now + TimeValue("00:00:03"))
End If
End If
End If
Next RowCnt
End Sub
WhatsAppNotification.xlsm | |||||||
---|---|---|---|---|---|---|---|
A | B | C | D | E | |||
1 | |||||||
2 | WhatsApp contact or Group name | Notification date | Customized messag | Sent msg date | |||
3 | WhatsApp contact or Group | Mobile phone number | |||||
4 | KatJeremy | +49 1590 684354 | 12/26/2024 | Dear Jeremy Katatumba, your subscription has expired please renew when you get a chance, thank you. KF Co. Ltd. | |||
5 | Joseph Rwanjagarara | +44 7956 8543478 | 12/27/2024 | Dear Joseph Rwanjagarara, your subscription has expired please renew when you get a chance, thank you. KF Co. Ltd. | |||
6 | Regina Marianna Katatumba | +1 (515) 21065447 | 1/1/2025 | Dear Regina K Senteza, your subscription has expired please renew when you get a chance, thank you. KF Co. Ltd. | |||
7 | KatPatricia | +256 750 167543 | 1/11/2025 | Dear Patricia Katatumba, your subscription has expired please renew when you get a chance, thank you. KF Co. Ltd. | |||
8 | KatPhilip | +256 750 1675589 | 1/11/2025 | Dear Philip Katatumba, your subscription has expired please renew when you get a chance, thank you. KF Co. Ltd. | |||
9 | Paula B | +256 775 5449443 | 1/14/2025 | Dear Hazel Izooba, your subscription has expired please renew when you get a chance, thank you. KF Co. Ltd. | |||
10 | Paula B | +256 775 65488543 | 1/14/2025 | Dear Rachael Izooba, your subscription has expired please renew when you get a chance, thank you. KF Co. Ltd. | |||
11 | Ricky | +256 779 1679543 | 1/14/2025 | Dear Ricky Izooba, your subscription has expired please renew when you get a chance, thank you. KF Co. Ltd. | |||
12 | Paula B | +256 775 328754488 | 1/14/2025 | Dear Paula I Bwitirire, your subscription has expired please renew when you get a chance, thank you. KF Co. Ltd. | |||
Notifications |
Thanks have a nice day.