PDA

View Full Version : Modify Email macro to check cells for entry prior to emailing.



dcgrove
07-09-2009, 01:35 PM
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:


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.


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

mdmackillop
07-09-2009, 04:04 PM
Test first and call the Mailing macro if no proble,s exist

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