• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Blank Cell

B

bachuwar.rajenderprasad

New Member
Dear All,


I have a sheet and it has one Button. That Button will send the active workbook through mail.

But before sending that it should check E4,E6,E7,E8,E9,E10,E12,E13,E15,E16,E17,G4,G6,G7,G8,G9,G10,G12,G13,G15,G16,G17,H4,H6,H7,H8,H9,H10,H12,H13,H15,H16,H17 whether these cells are filled or not.


If not filled, it should throw an error, Particular cell is blank, You cant send this until you fill that.


Please help


Prasad
 
How's this?

[pre]
Code: 
Sub CheckCells()
Dim MyRange As Range
Set MyRange = Range("E4,E6,E7,E8,E9,E10,E12,E13,E15,E16,E17,G4,G6,G7,G8,G9,G10,G12,G13,G15,G16,G17,H4,H6,H7,H8,H9,H10,H12,H13,H15,H16,H17")
Dim FoundCell As Variant
On Error Resume Next
Set FoundCell = MyRange.Find(what:="", matchbyte:=True)
On Error GoTo 0
If Not (FoundCell Is Nothing) Then
MsgBox "Cell " & FoundCell.Address(False, False) & " is blank." & _
vbNewLine & "You can't send this until you fill it out.", vbOKOnly
Exit Sub
End If

'Mail the workbook
End Sub
[/pre]
 
wow..Thanks ton..its working..I am bashing my head since morning as am poor in VBA.


One more thing, the below is the code for sending mail.

In subject line, I want whatever value is there in B3 Cell to be added to Subject line.

And Body Should be as below. And signature should also B3 Cell value


"Dear All,


Please find the attached Template.


Regards,

Signature"

My Previous Code

[pre]
Code: 
Public Sub SendBasicEmail()
On Error GoTo Proc_Error
'
'
'

Dim oOutlook                    As Object
Dim oMessage                    As Object
Dim objOutlook                  As Object
Dim objOutlookMsg               As Object
Dim objOutlookRecip             As Object
Dim objOutlookAttach            As Object

Const olMailItem                As Long = 0
Const olTo                      As Long = 1

Dim intRow          As Integer
Dim intLastRow      As Integer
Dim arrWorkArea     As Variant
Dim strBody         As String
Dim strname As String
strname = Range("B3").Value

strBody = "Please find the attached One on One templete" & vbCrLf
'
'  Compose and send e-mail
'
Set oOutlook = CreateObject("Outlook.Application")
Set oMessage = oOutlook.CreateItem(olMailItem)
With oMessage
oMessage.Attachments.Add ActiveWorkbook.FullName
Set objOutlookRecip = .Recipients.Add("Rajender_Prasad@XYZ.com")
objOutlookRecip.Type = olTo
objOutlookRecip.Resolve
Set objOutlookRecip = .Recipients.Add("Rajender_Prasad@XYZ.com")
objOutlookRecip.Type = olTo
objOutlookRecip.Resolve
Set objOutlookRecip = .Recipients.Add("Rajender_Prasad@XYZ.com")
objOutlookRecip.Type = olTo
objOutlookRecip.Resolve
.CC = "Rajender_Prasad@infosys.com"
.Subject = "One On One" & Range("B3")
.Body = strBody
'        .Importance = olImportanceHigh
.Display
'or
.Save
.Send
End With

Proc_Exit:

Set oMessage = Nothing
Set oOutlook = Nothing

Exit Sub

Proc_Error:

Select Case Err
Case 287 ' Outlook not open
MsgBox "Please open Outlook to send email", vbOKOnly
Resume
Case Else
MsgBox "Error " & CStr(Err) & ": " & Err.Description
Resume Proc_Exit
End Select

Exit Sub

End Sub
[/pre]
 
How's this?

[pre]
Code: 
Public Sub SendBasicEmail()
On Error GoTo Proc_Error
'
'
'

Dim oOutlook                    As Object
Dim oMessage                    As Object
Dim objOutlook                  As Object
Dim objOutlookMsg               As Object
Dim objOutlookRecip             As Object
Dim objOutlookAttach            As Object

Const olMailItem                As Long = 0
Const olTo                      As Long = 1

Dim intRow          As Integer
Dim intLastRow      As Integer
Dim arrWorkArea     As Variant
Dim strBody         As String
Dim strName As String
strName = Range("B3").Value

'New code
Dim MyRange As Range
Set MyRange = Range("E4,E6,E7,E8,E9,E10,E12,E13,E15,E16,E17,G4,G6,G7,G8,G9,G10,G12,G13,G15,G16,G17,H4,H6,H7,H8,H9,H10,H12,H13,H15,H16,H17")
Dim FoundCell As Variant
On Error Resume Next
Set FoundCell = MyRange.Find(what:="", matchbyte:=True)
On Error GoTo 0
If Not (FoundCell Is Nothing) Then
MsgBox "Cell " & FoundCell.Address(False, False) & " is blank." & _
vbNewLine & "You can't send this until you fill it out.", vbOKOnly
Exit Sub
End If

'Changed this string as well
strBody = "Dear All" & vbNewLine & vbNewLine & _
"Please find the attached One on One templete." & vbNewLine & vbNewLine & _
"Regards," & vbNewLine & _
strName
'
'  Compose and send e-mail
'
Set oOutlook = CreateObject("Outlook.Application")
Set oMessage = oOutlook.CreateItem(olMailItem)
With oMessage
oMessage.Attachments.Add ActiveWorkbook.FullName
Set objOutlookRecip = .Recipients.Add("Rajender_Prasad@XYZ.com")
objOutlookRecip.Type = olTo
objOutlookRecip.Resolve
Set objOutlookRecip = .Recipients.Add("Rajender_Prasad@XYZ.com")
objOutlookRecip.Type = olTo
objOutlookRecip.Resolve
Set objOutlookRecip = .Recipients.Add("Rajender_Prasad@XYZ.com")
objOutlookRecip.Type = olTo
objOutlookRecip.Resolve
.CC = "Rajender_Prasad@infosys.com"
.Subject = "One On One " & strName
.Body = strBody
'        .Importance = olImportanceHigh
.Display
'or
.Save
.Send
End With

Proc_Exit:

Set oMessage = Nothing
Set oOutlook = Nothing

Exit Sub

Proc_Error:

Select Case Err
Case 287 ' Outlook not open
MsgBox "Please open Outlook to send email", vbOKOnly
Resume
Case Else
MsgBox "Error " & CStr(Err) & ": " & Err.Description
Resume Proc_Exit
End Select

Exit Sub

End Sub
[/pre]
 
Put this bit of code after the validation section.

[pre]
Code: 
Dim xResponse As Double
xResponse = MsgBox("Are you sure you want to submit?", vbYesNo, "Confirm")
If xResponse <> vbYes Then Exit Sub
[/pre]
 
You must log in or register to reply here.
Back
Top