Modify Email macro to check cells for entry prior to emailing.

Hello, I am using the code below tied to a button on the worksheet to email a sheet and would like it to check that there has been text entered intothe cells below prior to emailing the sheet. If the cells have no text entered i would like a message box to pop up stating that all fields need to be completed.

Range of cells:
H6,A9,F9,A12,F12,A16,A23,A26,C28,D30,D32,D34,A37,D39,F36,F28


Email code I am using:

Code:

---

Sub Mail_Range()
' Works in Excel 2000 through Excel 2007.
Dim Source As Range
Dim Destwb As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long

ActiveSheet.Unprotect
Set Source = Nothing
On Error Resume Next
Set Source = Range("A1:I55").SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If Source Is Nothing Then
  MsgBox "The source is not a range or the worksheet is protected. Please correct the problem and try again.", vbOKOnly
  Exit Sub
End If

With Application
  .ScreenUpdating = False
  .EnableEvents = False
End With
 
Set wb = ActiveWorkbook
Set Destwb = Workbooks.Add(xlWBATWorksheet)

Source.Copy
With Destwb.Sheets(1)
  ' The number 8 pastes the column width. Because of
  ' of a bug in Excel 2000, you must use the number
  ' instead of “xlPasteColumnWidths”.
  .Cells(1).PasteSpecial Paste:=8
  .Cells(1).PasteSpecial Paste:=xlPasteValues
  .Cells(1).PasteSpecial Paste:=xlPasteFormats
  .Cells(1).Select
  Application.CutCopyMode = False
End With

TempFilePath = Environ$("temp") & "\"
TempFileName = "" & wb.Name & " " & Format(Now, "dd-mmm-yy")

If Val(Application.Version) < 12 Then
  ' You are using Excel 2000 through Excel 2003.
  FileExtStr = ".xls": FileFormatNum = -4143
Else
  ' You are using Excel 2007.
  FileExtStr = ".xlsx": FileFormatNum = 51
End If

With Destwb
  .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
  On Error Resume Next
  .SendMail "nospam@nospam.com", _
      Sheets("sheet1").Range("a1").Value
  On Error GoTo 0
  .Close SaveChanges:=False
End With

' Delete the file you just sent.
Kill TempFilePath & TempFileName & FileExtStr

With Application
  .ScreenUpdating = True
  .EnableEvents = True
End With
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False
End Sub

---

I tried to adapt this code, but it is far to advanced for me to wrap my head around. If it could be made to check the range of cells I have provided prior to the execution of the code above that would be fantastic.

Code:

---

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim Start As Boolean
    Dim Rng1 As Range, Rng3 As Range, Rng4 As Range
   
    Dim Prompt As String, RngStr As String
    Dim Cell As Range
    'set your ranges here
    'Rng1 is on sheet "Group Profile" and cells B5 through B14
    'Cell F1, A range of F5 through F7 etc.  you can change these to
    'suit your needs.
    Set Rng1 = Sheets("Group Profile").Range("B5:B14,F1,F5:F7,B20:B22,B26:B31,B38:B45,B49:B52")
    Set Rng3 = Sheets("Eligibility Guidelines").Range("F1,E5,E6,E9,E10,B7:B17,B21:B36")
    Set Rng4 = Sheets("COBRA").Range("J2,H4,H5,J15,B4,B5,B9,B10:B13,B17:B20,B25:B28,E17:  E20")
    'message is returned if there are blank cells
    Prompt = "Please check your data ensuring all required " & _
    "cells are complete." & vbCrLf & "you will not be able " & _
    "to close or save the workbook until the form has been filled " & _
    "out completely. " & vbCrLf & vbCrLf & _
    "The following cells are incomplete and have been highlighted yellow:" _
    & vbCrLf & vbCrLf
    Start = True
    'highlights the blank cells
    For Each Cell In Rng1
        If Cell.Value = vbNullString Then
            Cell.Interior.ColorIndex = 6 '** color yellow
            If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
            Start = False
            RngStr = RngStr & Cell.Address(False, False) & ", "
        Else
            Cell.Interior.ColorIndex = 0 '** no color
        End If
    Next
    If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 2)
    Start = True
    If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
    For Each Cell In Rng3
        If Cell.Value = vbNullString Then
            Cell.Interior.ColorIndex = 6 '** color yellow
            If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
            Start = False
            RngStr = RngStr & Cell.Address(False, False) & ", "
        Else
            Cell.Interior.ColorIndex = 0 '** no color
        End If
    Next
  If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 2)
    Start = True
    If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
    For Each Cell In Rng4
        If Cell.Value = vbNullString Then
            Cell.Interior.ColorIndex = 6 '** color yellow
            If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
            Start = False
            RngStr = RngStr & Cell.Address(False, False) & ", "
        Else
            Cell.Interior.ColorIndex = 0 '** no color
        End If
    Next
    If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 2)
    If RngStr <> "" Then
        MsgBox Prompt & RngStr, vbCritical, "Incomplete Data"
        Cancel = True
    Else
        'saves the changes before closing
        ThisWorkbook.Save
        Cancel = False
    End If
 
    Set Rng1 = Nothing
    Set Rng3 = Nothing
    Set Rng4 = Nothing
     
End Sub

---

Thank you for any help you may be able to provide!

Clayton

Test first and call the Mailing macro if no proble,s exist
[vba]
Option Explicit
Sub Macro1()
Dim Rng As Range, Cel As Range
Dim Test As Boolean
Set Rng = Range("A1,A3,A5") '<==change to suit
For Each Cel In Rng
If Cel = "" Then
Test = True
Cel.Interior.ColorIndex = 6
Else
Cel.Interior.ColorIndex = xlNone
End If
Next
If Test Then
MsgBox "Please complete yellow cells"
Else
Call Mail_Range
End If
End Sub

Sub Mail_Range()
MsgBox "Mailing"
End Sub

[/vba]