Return value of dynamically determined cell - vba

The code below verifies if column A in "Sheet1" has the same value as column A in "Sheet2". If so, an email address should be taken from column B "Sheet2".
My problem is getting the email address from "Sheet2" column B.
Sub mail()
Dim A As Long
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim wb As Workbook
Dim check
Set wb = Excel.ActiveWorkbook
Set sh1 = wb.Worksheets(1)
Set sh2 = wb.Worksheets(2)
Application.ScreenUpdating = False
For A = 2 To sh1.Cells(Rows.Count, "A").End(xlUp).Row
check = Application.match(sh1.Cells(A, 1).Value, sh2.Columns(1), 0)
If IsError(check) Then
MsgBox "No email was found!"
Else
' i am not able to set this.
'h = take the email address from sheet2 column B
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.createItem(olmailitem)
Set wb2 = ActiveWorkbook
ActiveWorkbook.Save
With OutMail
.Display
.To = h ' attached the email address
.cc = ""
.BCC = ""
.Subject = "Test - " '& B & " " & F
.htmlbody = "<p style='font-family:calibri;font-size:15'>" & "Hi " & C & "<BR/>" & "<BR/>" & "Please check the attached template." & "<br/>" & "<BR/>" & "Change data if required." & "<BR/>" & "<br/>" & "This e-mail has been automatically send! " & "<br/>" & "<br/>" & "With best regards," & "<br/>" & "<br/>"
.attachments.Add wb2.FullName
End With
ActiveWorkbook.Close
End If
Next
End Sub

With the help of "PEH" i succeed in finding a solution for this:
Sub mail()
Dim A As Long
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim wb As Workbook
Dim check
Set wb = Excel.ActiveWorkbook
Set sh1 = wb.Worksheets(1)
Set sh2 = wb.Worksheets(2)
For A = 2 To sh1.Cells(Rows.Count, "A").End(xlUp).Row
check = Application.match(sh1.Cells(A, 1).Value, sh2.Columns(1), 0)
If IsError(check) And Not IsEmpty(sh1.Cells(A, 1)) Then
MsgBox "No email was found!"
Else
h = sh2.Cells(check, 2).Value
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.createItem(olmailitem)
Set wb2 = ActiveWorkbook
wb.Save
With OutMail
.Display
.To = h
.cc = ""
.BCC = ""
.Subject = "Test - " '& B & " " & F
.htmlbody = "<p style='font-family:calibri;font-size:15'>" & "Hi " & C & "<BR/>" & "<BR/>" & "Please check the attached template." & "<br/>" & "<BR/>" & "Change data if required." & "<BR/>" & "<br/>" & "This e-mail has been automatically send! " & "<br/>" & "<br/>" & "With best regards," & "<br/>" & "<br/>"
.attachments.Add wb2.FullName
End With
wb.Close
End If
Next
End Sub

Related

Sending Email for Each Row in Pivot Table

I'm attempting to send an email for each attendance event that is being displayed within the Pivot Table. Though it will recognize the count of rows, only the 1st row is being sent in email up to as many emails as there are rows of data.
I believe I need my offset parameters to change so it's changing by row & cell. Any suggestions?
enter image description here
Sub EmailBody()
Application.ScreenUpdating = False
ThisWorkbook.RefreshAll
'Tells it to re-run every x hours and min.
Application.OnTime Now + TimeValue("1:00"), "EmailBody"
Dim sourceSheet As Worksheet
Set sourceSheet = ActiveSheet
Dim arrHolidays As Variant, iDay As Variant
arrHolidays = Application.Transpose(Worksheets("Hold").Range("a:a").Value) 'Add all your holidays on Holidays worksheet
For Each iDay In arrHolidays
If Date = iDay Then Exit Sub 'exit this sub if date is a holiday
Next
On Error Resume Next
ThisWorkbook.RefreshAll
Worksheets("Sheet1").Activate
'Creating references to Application and MailItem Objects of Outlook
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
'Creating variable to hold values of different items of mail
Dim sendTo, MailBody As String
Dim lstRow As Long
ThisWorkbook.Sheets("Sheet1").Activate
'Getting last row of containing email id.
lstRow = Cells(Rows.Count, 2).End(xlUp).Row
Dim rng As Range
Set rng = Range("B2:B" & lstRow)
'initializing outlook object to access its features
Set outApp = New Outlook.Application
On Error GoTo cleanup 'to handle any error during creation of object.
For Each i In Range("b2:b100")
MailBody = "Please see the following attendance event logged in SharePoint for " & i.Offset(0, -1) & "." & vbCr & vbCr & "Date of Absence " & " : " & i.Offset(0, 2) & vbCr & "Reason for Absence " & " : " & i.Offset(0, 3) & vbCr & "Ticket Entered on" & " : " & i.Offset(0, 4) & vbCr & "Created By" & " : " & i.Offset(0, 5) & vbCr & "Notes" & " : " & i.Offset(0, 6) & vbCr & vbCr & "Please reach out to DLWESTCCWALKERRETENTIONREPORTING#charter.com, if you have any questions."
For Each cell In rng
sendTo = Range(cell.Address).Offset(0, 0).Value2 & ";" & Range(cell.Address).Offset(0, 1).Value2
Subj = "Attendance Callout Event Notification"
Msg = MailBody
On Error Resume Next 'to hand any error during creation of below object
Set outMail = outApp.CreateItem(0)
'Writing and sending mail in new mail
With outMail
.To = sendTo
.Body = Msg
.Subject = Subj
.Display '
.Send
End With
On Error GoTo 0 'To clean any error captured earlier
Set outMail = Nothing 'nullifying outmail object for next mail
Next cell 'loop ends
cleanup: 'freeing all objects created
Set outApp = Nothing
Application.ScreenUpdating = True
Application.ScreenUpdating = True
Next
End Sub

Looping through unread emails, changing unread to read, using For Each

I wrote code to pick up unread email and with other criteria.
The code runs but For Each itm In olFolder.Items.Restrict(sFilter) is not working.
For example if there are 4 unread emails in the inbox the For Each should loop 4 times but the loop is happening only 2 times.
Sub ReadOutlookEmails_WithCriteria()
Dim olApp As Outlook.Application, olNs As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder, olMail As Outlook.MailItem
Dim eFolder As Outlook.Folder '~~> additional declaration
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim objAtt As Outlook.Attachment
Dim olItem As Outlook.MailItem
Dim olReply As MailItem ' Reply
Dim olRecip As Recipient
Dim i As Long
Dim x As Date, ws As Worksheet '~~> declare WS variable instead
Dim lrow As Long '~~> additional declaration
Set ws = ActiveSheet '~~> or you can be more explicit using the next line
Set EC = ThisWorkbook.Sheets("Email Search Criteria")
Set IE = ThisWorkbook.Sheets("Inbox Emails")
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("Rejected Emails")
Todays_Date = EC.Range("E2").Value
IE.Rows("2:10000").Clear
Incr = 2
For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
If eFolder = "Mandatory Training Enrollment" Then 'IF_Check_1
Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(eFolder.Name): Debug.Print olFolder
sFilter = "[ReceivedTime] >= '" & Todays_Date & "' AND [UNREAD]=TRUE"
Debug.Print olFolder.Items.Restrict(sFilter).Count
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
For Each itm In olFolder.Items.Restrict(sFilter) ''''Problem is over here
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
If itm.Attachments.Count = EC.Range("B2") Then 'itm Like "*" & EC.Range("A2") & "*" And'IF_Check_2
For Each objAtt In itm.Attachments
Debug.Print "Subject Name - " & itm: Debug.Print "Attachment Type - " & objAtt.DisplayName
Debug.Print "Attachment Size - " & objAtt.Size: Debug.Print "Attachments Count - " & objAtt.Index
Debug.Print "Subject Name - " & EC.Range("A2"): Debug.Print "Attachment Type - " & EC.Range("C2")
Debug.Print "Attachment Size - " & EC.Range("D2"): Debug.Print "Attachments Count - " & EC.Range("B2")
If objAtt.Size <= EC.Range("D2") And UCase(objAtt.Filename) Like UCase("*" & EC.Range("C2")) Then
IE.Range("A" & Incr) = olFolder
IE.Range("B" & Incr) = itm.SenderName
IE.Range("C" & Incr) = itm
IE.Range("D" & Incr) = objAtt.DisplayName
IE.Range("E" & Incr) = itm.Attachments.Count
IE.Range("F" & Incr) = objAtt.Size
IE.Range("G" & Incr) = "Pass"
Set olReply = itm.ReplyAll
'Set olRecip = olReply.Recipients.Add("Email Address Here") ' Recipient Address
'olRecip.Type = olCC
olReply.Body = "Hello," & vbNewLine & vbNewLine & "Email Success" & vbNewLine & vbNewLine & "Thank you. " & vbCrLf & olReply.Body
olReply.Display
'olReply.SentOnBehalfOfName = onBehalfOf
'olReply.SendUsingAccount = getGenericMailboxAccount(onBehalfOf)
olReply.Send
itm.UnRead = False
End If
Next objAtt
ElseIf itm.Attachments.Count <> EC.Range("B2") Then 'IF_Check_2
FailReason1 = "Attament is not a PDF"
FailReason2 = "Attachment size is more than 10MB"
FailReason3 = "Attachment is missing with email"
FailReason4 = "Attachments are more than 1"
IE.Range("A" & Incr) = olFolder
IE.Range("B" & Incr) = itm.SenderName
IE.Range("C" & Incr) = itm
IE.Range("D" & Incr) = ""
IE.Range("E" & Incr) = itm.Attachments.Count
IE.Range("F" & Incr) = ""
IE.Range("G" & Incr) = "Fail"
EBody = "Hello," & vbNewLine & vbNewLine & "Email Not Success." & vbNewLine & vbNewLine _
& "Fail Reason Might Be One Of The Below Mentioned:" & vbNewLine & vbNewLine _
& "*" & FailReason1 & vbNewLine & vbNewLine _
& "*" & FailReason2 & vbNewLine & vbNewLine _
& "*" & FailReason3 & vbNewLine & vbNewLine _
& "*" & FailReason4 & vbNewLine & vbNewLine _
Set olReply = itm.ReplyAll
'Set olRecip = olReply.Recipients.Add("Email Address Here") ' Recipient Address
'olRecip.Type = olCC
'olReply.Body = "Hello," & vbCrLf & "Email Not Success" & vbCrLf & FailReason1 & vbCrLf & FailReason2 & vbCrLf & FailReason3 & vbCrLf & olReply.Body
olReply.Body = EBody & vbCrLf & olReply.Body
olReply.Display
'olReply.SentOnBehalfOfName = onBehalfOf
'olReply.SendUsingAccount = getGenericMailboxAccount(onBehalfOf)
olReply.Send
itm.UnRead = False
itm.Move SubFolder
End If 'IF_Check_2
Incr = Incr + 1
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Next itm ' Its passing to the next statement even though loop is not completed.
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Set olFolder = Nothing
End If ''IF_Check_1
Next eFolder
End Sub
Your are modifying (by setting the Unread property to false) the very collection you are iterating over.
Do not use foreach - use a down loop.
set restrItems = olFolder.Items.Restrict(sFilter)
For i = restrItems.Count to 1 Step -1
set itm = restrItems(i)
First of all, you need to make sure the date object is formatted in the way Outlook understands:
sFilter = "[ReceivedTime] >= '" & Todays_Date & "' AND [UNREAD]=TRUE"
Use the Format function available in VBA.
sFilter = "[ReceivedTime] > '" & Format(Todays_Date, "ddddd h:nn AMPM") & "'"

Saving data in a cell in the next empty row

I have code which sends a file via Outlook and gets-saves data into an Excel file.
For sending a file via Outlook, it works perfectly. However it saves data into the same row of the Excel file. Code should save data into the next empty row of the Excel file.
Sub AutoEmail()
On Error GoTo Cancel
Dim Resp As Integer
Resp = MsgBox(prompt:=vbCr & "Yes = Review Email" & vbCr & "No = Immediately Send" & vbCr & "Cancel = Cancel" & vbCr, _
Title:="Review email before sending?", _
Buttons:=3 + 32)
'dfsfsd
Range("S20").Copy
Range("T20").PasteSpecial xlPasteValues
'sdaasdf
Workbooks.Open ("C:\Users\computername\Desktop\New folder (2)\ff.xlsx")
ThisWorkbook.Activate
'1
Workbooks("1435250.xlsx").Worksheets("RFI").Range("T20").Copy _
Workbooks("ff.xlsx").Worksheets("Sayfa1").Range("P2")
'1
Select Case Resp
'Yes was clicked, user wants to review email first
Case Is = 6
Dim myOutlook As Object
Dim myMailItem As Object
Set otlApp = CreateObject("Outlook.Application")
Set otlNewMail = otlApp.CreateItem(olMailItem)
FName = Application.ActiveWorkbook.FullName
With otlNewMail
.To = Cells(33, 10)
.CC = Cells(1, 1)
.Subject = Cells(23, 10) & ": " & Cells(21, 10)
.Body = "this is a text" & vbCr & vbCr & "" & Cells(23, 10) & "."
.Attachments.Add FName
.Display
End With
Set otlNewMail = Nothing
Set otlApp = Nothing
Set otlAttach = Nothing
Set otlMess = Nothing
Set otlNSpace = Nothing
'If no is clicked
Case Is = 7
Dim myOutlok As Object
Dim myMailItm As Object
Set otlApp = CreateObject("Outlook.Application")
Set otlNewMail = otlApp.CreateItem(olMailItem)
FName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
With otlNewMail
.To = ""
.CC = ""
.Subject = ""
.Body = "Good Morning," & vbCr & vbCr & " " & Format(Date, "MM/DD") & "."
.Attachments.Add FName
.Send
'.Display
'Application.Wait (Now + TimeValue("0:00:01"))
'Application.SendKeys "%s"
End With
'otlApp.Quit
Set otlNewMail = Nothing
Set otlApp = Nothing
Set otlAttach = Nothing
Set otlMess = Nothing
Set otlNSpace = Nothing
'If Cancel is clicked
Case Is = 2
Cancel:
MsgBox prompt:="No Email has been sent.", _
Title:="EMAIL CANCELLED", _
Buttons:=64
End Select
End Sub
How can I save data (End(xlUp).Row) into the next empty row of an Excel file?
Change:
Workbooks("1435250.xlsx").Worksheets("RFI").Range("T20").Copy _
Workbooks("ff.xlsx").Worksheets("Sayfa1").Range("P2")
To this:
With Workbooks("ff.xlsx").Worksheets("Sayfa1")
Workbooks("1435250.xlsx").Worksheets("RFI").Range("T20").Copy .Range("P" & .Range("P" & .Rows.count).End(xlUp).Row + 1)
End With

Send e-mail dependant on specific cell contents

I am a novice VBA programmer and I have searched for this but am unable to find a solution that exactly matches what I need.
I have a code to ping out customer's IP address but I only need e-mail notifications for the pings that have timed out.
The ping results are in column D and the e-mails are in column E of my spreadsheet. I'd be grateful for any help.
Thanks in advance.
Dim OutlookApp
Dim objMail
Dim x As Long
Dim PingResults As range
lastrow = Sheets("Ping").Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To lastrow
Set PingResults = range("d2:D250")
Set OutlookApp = CreateObject("Outlook.Application")
Set objMail = OutlookApp.CreateItem(olMailItem)
If PingResults.Cells.Value = "Request timed out." Then
objMail.To = Cells(x, 5).Value
With objMail
.Subject = Cells(x, 1) & " " & "-" & " " & Cells(x, 2) & " " & "-" & " " & Cells(x, 3)
.Body = "Run Diagnostics. Customer's broadband appears to have issues" & vbCrLf & Cells(x, 4)
.Display
.Save
End With
SendKeys "%{s}", True
ElseIf PingResults.Cells.Value = "" Then
Set OutlookApp = Nothing
Set objMail = Nothing
End If
End Sub
you most probably are after this:
Option Explicit
Sub main()
Dim pingResults As Range, cell As Range
With Sheets("Ping")
With .Range("D1", .Cells(.Rows.Count, "D").End(xlUp))
.AutoFilter Field:=1, Criteria1:="Request timed out."
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Set pingResults = .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible)
End With
.AutoFilterMode = False
End With
If Not pingResults Is Nothing Then
With CreateObject("Outlook.Application")
For Each cell In pingResults
With .CreateItem(0) '<--| olMailItem is an item of an OutLook enumeration whose value is "zero"
.Display
.to = cell.Offset(, 1).Value
.Subject = cell.Offset(, -3) & " " & "-" & " " & cell.Offset(, -2) & " " & "-" & " " & cell.Offset(, -1)
.Body = "Run Diagnostics. Customer's broadband appears to have issues" & vbCrLf & cell.Value
.Save
End With
SendKeys "%{s}", True
Next
.Quit
End With
End If
End Sub
This should do it:
Dim OutlookApp
Dim objMail
Dim x As Long
Dim PingResults As Range
Set OutlookApp = CreateObject("Outlook.Application")
lastrow = Sheets("Ping").Cells(Rows.Count, 1).End(xlUp).Row
Set PingResults = Range("d1:D" & lastrow)
For x = 2 To lastrow
If PingResults.Cells(x, 1).Value = "Request timed out." Then
Set objMail = OutlookApp.CreateItem(olMailItem)
With objMail
.To = Cells(x, 5).Value
.Subject = Cells(x, 1) & " " & "-" & " " & Cells(x, 2) & " " & "-" & " " & Cells(x, 3)
.Body = "Run Diagnostics. Customer's broadband appears to have issues" & vbCrLf & Cells(x, 4)
.Display
.Save
End With
SendKeys "%{s}", True
Set objMail = Nothing
End If
Next x
Set OutlookApp = Nothing

Stop macro if column is blank excel vba

I have made some code but if the range R2:34 is blank, it will still open the template email with no data in him. Please tell me where am I doing the bad connection.
Sub 1()
Dim OutApp As Object
Dim OutMail As Object
Dim sTo As String
Dim spo As String
Dim emailRng As Range, cl As Range, dtrecuta As Range
Dim c As Range
For Each cell In Cells.Range("N2:N34")
If LCase(Cells(cell.Row, "N").Value) = "0" Or LCase(Cells(cell.Row, "N").Value) < "480" Then
On Error Resume Next
Cells(cell.Row, "R").Value = Cells(cell.Row, "M").Value
Else
Cells(cell.Row, "R").Value = Null
End If
Next cell
a = CLng(Date)
Set emailRng = Worksheets("Sheet1").Range("r2:r34")
Set dtrecuta = Worksheets("Sheet1").Range("P2")
For Each cl In emailRng
sTo = sTo & ";" & cl.Value
Next
sTo = Mid(sTo, 2)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItemFromTemplate("C:\Users\Marius\AppData\Roaming\Microsoft\Templates\statistica.oft")
On Error Resume Next
With OutMail
.To = sTo
.CC = ""
.BCC = ""
.Subject = "TESTARE Statistica pentru data de " & dtrecuta
strbody = "Buna " & " , " & vbNewLine & vbNewLine & _
"Te rog sa trimiti statistica astazi " & a & " pana in ora 10:00, " & _
" pentru data de " & dtrecuta & vbNewLine & vbNewLine & "O zi buna." & _
" " & vbNewLine & vbNewLine & " Acesta este un mesaj automat nu raspundeti la acest e-mail. "
.Display
.Body = strbody & Signature
.send
End With
On Error GoTo cleanup
Set OutMail = Nothing
cleanup:
Set OutMail = Nothing
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Add an IF statement just after setting your range to check if it is all blank cells:
Set emailRng = Worksheets("Sheet1").Range("r2:r34")
If WorksheetFunction.CountBlank(emailRng) = emailRng.Cells.Count Then Exit Sub 'No data