I built a script to create emails addressed to different people with individual attachments included. I have different subroutines that are called from this Mother Script.
It works until the subroutine Distribution is called. It stops at
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
Sub Distribution()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
Dim StrBody As String
StrBody = "<BODY style=font-size:11pt;font-family:Arial>Hi team," & "<br><br>" & _
"Please find attached the most updated version of the Weekly Report. " & "<br>" & _
"If you have any doubt or comment, do not hesitate to reach out to us." & "<br><br>" & _
"Jorge Martinez"
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
Windows("Free Trade Zone Weekly Reports.xlsm").Activate
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.CC = "[email protected]"
.Subject = "Weekly Report " & Date
Bodyformat = 2
'.Body = "<BODY style=font-size:11pt;font-family:Arial>Hi team," & "<br><br>" & _
"Please find attached the most updated version of the Weekly Report " & "<br>" & _
"If you have any doubt or comment, do not hesitate to reach out to us." & "<br><br>" & cell.Offset(0, -1).Value
.Importance = 2
.HTMLBody = StrBody & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Display 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
I took it from Ron DeBruin's website.
The error is:
no data in selected cells.
If I stop the mother script and run this subroutine independently, it goes without any type of issue.
I thought it would be fixed by activating the workbook that contains the script prior to that line, but no success.
When working with SpecialCells
you have to be very careful. Try this
Replace
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
with
Dim rng As Range
On Error Resume Next
Set rng = sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "No Range with constants were found"
Exit Sub
End If
For Each cell In rng