Saving data in a cell in the next empty row - vba

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

Related

Using Excel VBA IF THEN statment in the body of an email

I am trying to use the if then statement inside the .body of my email, but when ever I run it, it does nothing. Below where I noted the body of the email starts is where I am stuck.
Sub Email_From_Excel_Basic()
' This identifies what means what
Dim emailApplication As Object
Dim emailItem As Object
Dim mymsg As String
Dim cell As Range
Application.ScreenUpdating = False
Set emailApplication = CreateObject("Outlook.Application")
' Now we build the email.
On Error GoTo cleanup
For Each cell In Worksheets("owvr").Columns("S").Cells
Set emailItem = emailApplication.CreateItem(0)
If cell.Value Like "?*#?*.?*" And _
Cells(cell.Row, "T") = "Yes" Then
With emailItem
' This is who the email is being sent to
.To = Cells(cell.Row, "S").Value
.CC = Cells(cell.Row, "S").Value
' This is the subject of the email
.Subject = "Status update"
' This is the body of the email based on cell references
mymsg = "Dear " & Cells(cell.Row, "A").Value & " team," & vbNewLine & vbNewLine
Here
mymsg = mymsg & "Status: " & If Cell("D").Value = "1. New Order" Then
mymsg "Your order has been received and will processed."
ElseIf cell("D").Value= "2. Shipped" Then
mymsg = mymsg & "Status: Your order has been shipped" & vbNewLine
Else
End If
mymsg = mymsg & "Deposit invoice: " & Cells(cell.Row, "K").Value & vbNewLine
mymsg = mymsg & "Additional invoice: " & Cells(cell.Row, "M").Value & vbNewLine
.Body = mymsg
.Send
' This part brings the loop back up to the top, so this way it goes to the next email in the column
End With
On Error GoTo 0
Set emailItem = Nothing
End If
Next cell
cleanup:
Set emailApplication = Nothing
Set emailItem = Nothing
Set mymsg = Nothing
Application.ScreenUpdating = True
End Sub
Advice?
Have the IF populate a variable string then concatenate that into the body.
Sub Email_From_Excel_Basic()
' This identifies what means what
Dim emailApplication As Object
Dim emailItem As Object
Dim mymsg As String
Dim cell As Range
Application.ScreenUpdating = False
Set emailApplication = CreateObject("Outlook.Application")
' Now we build the email.
On Error GoTo cleanup
For Each cell In Worksheets("owvr").Columns("S").Cells
Set emailItem = emailApplication.CreateItem(0)
If cell.Value Like "?*#?*.?*" And _
Cells(cell.Row, "T") = "Yes" Then
With emailItem
' This is who the email is being sent to
.To = Cells(cell.Row, "S").Value
.CC = Cells(cell.Row, "S").Value
' This is the subject of the email
.Subject = "Status update"
' This is the body of the email based on cell references
mymsg = "Dear " & Cells(cell.Row, "A").Value & " team," & vbNewLine & vbNewLine
Dim stts As String
If Cells(cell.Row, 4).Value = "1. New Order" Then
stts = "Your order has been received and will processed."
ElseIf Cells(cell.Row, 4).Value = "2. Shipped" Then
stts "Status: Your order has been shipped" & vbNewLine
Else
End If
mymsg = mymsg & "Status: " & stts
mymsg = mymsg & "Deposit invoice: " & Cells(cell.Row, "K").Value & vbNewLine
mymsg = mymsg & "Additional invoice: " & Cells(cell.Row, "M").Value & vbNewLine
.Body = mymsg
.Send
' This part brings the loop back up to the top, so this way it goes to the next email in the column
End With
On Error GoTo 0
Set emailItem = Nothing
End If
Next cell
cleanup:
Set emailApplication = Nothing
Set emailItem = Nothing
Set mymsg = Nothing
Application.ScreenUpdating = True
End Sub

Runtime Error - Cannot find this file; verify name & file path correct (Excel / VBA)

Running into error message in title when attempting to link attachments to email. The attachments are stored in Folder Names respective to the "type" of company, which is why I'm attempting to add a for loop to retrieve "type" from spreadsheet.
Sub mailTest()
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim olAttachmentLetter As Outlook.Attachments
Dim fileLocationLetter As String
Dim dType As String
For i = 2 To 3
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
Set olAttachmentLetter = olMail.Attachments
fileLocationLetter = "C:\...\user\Desktop\FileLocation"
letterName = "TestLetter1"
dType = Worksheets("Test1").Cells(i, 2).Value
mailBody = "Hello " _
& Worksheets("Test1").Cells(i, 4) _
& "," _
& Worksheets("BODY").Cells(2, 1).Value _
& Worksheets("BODY").Cells(3, 1).Value _
& Worksheets("BODY").Cells(4, 1).Value & " " & dType _
& Worksheets("BODY").Cells(5, 1).Value & " TTT" & dType & "xx18" _
& Worksheets("BODY").Cells(6, 1).Value _
& Worksheets("BODY").Cells(7, 1).Value
With olMail
.To = Worksheets("Test1").Cells(i, 5).Value
.Subject = Worksheets("Test1").Cells(i, 3).Value & " - "
.HTMLBody = "<!DOCTYPE html><html><head><style>"
.HTMLBody = .HTMLBody & "body{font-family: Calibri, ""Times New Roman"", sans-serif; font-size: 13px}"
.HTMLBody = .HTMLBody & "</style></head><body>"
.HTMLBody = .HTMLBody & mailBody & "</body></html>"
''Adding attachment
.Attachments.Add fileLocationLetter & letterName & ".pdf"
.Display
'' .Send (Once ready to send)
End With
Set olMail = Nothing
Set olApp = Nothing
Next
End Sub
What am I doing wrong here? The file is stored in 'C:...\user\Desktop\FileLocation\TestLetter1.pdf'
Thank you kindly.
You are missing the \ between the fileLocation and the letterName. Thus, either write this:
.Attachments.Add fileLocationLetter & "\" & letterName & ".pdf"
or this:
fileLocationLetter = "C:\...\user\Desktop\FileLocation\"
With much help from #Vityata, figured it out.
Essentially being able to make two attachments, one is static with known file name, the second attachment's name is dependent on stored cell value. The workaround was to break the path/name of the file as stored strings. Maybe there's an easier way, but this worked for me!
Code used:
Sub mailTest()
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
'' Identify Attachments
Dim olAttachmentLetter As Outlook.Attachments
Dim olAttachmentSSH As Outlook.Attachments
'' Identify Attachment Locations / Paths
Dim fileLocationLetter As String
Dim fileLocationSSH As String
Dim fileLocationSSHi As String
Dim fileLocationSSHii As String
'' Type Variable, referencing cell in worksheet where "Type" is stored (in loop below)
Dim dType As String
'' Creating the loop - Replace 4 with end of rows. Will eventually create code to automatically identify the last cell with stored value
For i = 2 To 4
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
Set olAttachmentLetter = olMail.Attachments
Set olAttachmentSSH = olMail.Attachments
''File Location for Letter
fileLocationLetter = "C:\...\Directory"
''File Location for Excel sheet - Need 3 fields as file name is dynamic based on loop value
fileLocationSSH = "C:\...\Directory\Excel Files"
fileLocationSSHi = "Beginning of File name..."
fileLocationSSHii = " ... End of File name"
letterName = "Name of PDF attachment"
dType = Worksheets("Test1").Cells(i, 2).Value
''Body of Email - Each new line represents new value (linking to hidden worksheet in Excel doc)
mailBody = "Hello " _
& Worksheets("Test1").Cells(i, 4) _
& "," _
& Worksheets("BODY").Cells(2, 1).Value _
& Worksheets("BODY").Cells(3, 1).Value _
& Worksheets("BODY").Cells(4, 1).Value & " " & dType _
& Worksheets("BODY").Cells(5, 1).Value _
& Worksheets("BODY").Cells(6, 1).Value _
& Worksheets("BODY").Cells(7, 1).Value
With olMail
.To = Worksheets("Test1").Cells(i, 5).Value
.Subject = Worksheets("Test1").Cells(i, 3).Value
.HTMLBody = "<!DOCTYPE html><html><head><style>"
.HTMLBody = .HTMLBody & "body{font-family: Calibri, ""Times New Roman"", sans-serif; font-size: 13px}"
.HTMLBody = .HTMLBody & "</style></head><body>"
.HTMLBody = .HTMLBody & mailBody & "</body></html>"
'' Adding attachments, referencing file locations and amending file name if needed
.Attachments.Add fileLocationLetter & "\" & letterName & ".pdf"
.Attachments.Add fileLocationSSH & "\" & dType & "\" & fileLocationSSHi & dType & fileLocationSSHii & ".xlsx"
.Display
'' .Send (Once ready to send)
End With
Set olMail = Nothing
Set olApp = Nothing
Next
End Sub

Writing Values Of Cells Into Another Excel In VBA

I have this code to send e-mail with attached via Outlook:
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)
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 = "Good morning" & 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
However there is another thing that i want to add. I want to write some cells into another excel after sending e-mail via Outlook, lets say A2 to B15. The excel file which i want to write on is in C:\Users\Computername\Desktop\Savingdata.xlsx
Mert,
Try the following, add these two lines at the beginning of your code:
Dim wbThisWorkbook, wbTheOneToSaveTo As Workbook
Set wbThisWorkbook = Workbooks("TheNameOfYourCurrentWorkbook")
Then after your sending routine, add this:
Set wbTheOneToSaveTo = Workbooks.Open ("C:\Users\Computername\Desktop\Savingdata.xlsx")
wbThisWorkbook.Sheets("TheNameOfThe Worksheet").Range("A2").Copy
wbTheOneToSaveTo.Sheets("TheNameOfTheWorksheet").Range("B15").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'adjust parameters according to your needs
wbTheOneToSaveTo.Close True
wbThisWorkbook.Activate
Hope this helps!

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

Runtime error if contact in Outlook doesn't exist

When I complete a piece of work I email it to certain people. It depends on the work who gets it.
If any person in the list leaves, changes job or has an email change the code will bug out saying
Run Time error -2147467259(80004005), Outlook Does Not Recognise One Or More Names
If I manually copy the email addresses in the list and pop them into Outlook and send I'll get an email back saying the user doesn't exist or has been changed.
I have tried On Error Resume Next and On Error Goto. I have added MS Outlook 14.0 Object Libary, SharePoint Social Provider, Social Provider Extensibility and Outlook View control from the references.
The code bugs out on the .send
Sub EMailer()
Application.ScreenUpdating = False
strfilepath = "\\DFZ70069\Data\199711009\workgroup\Res Plan Team\Performance Management\Specialised Reporting\Debit & Credit Reporting\Masters\Sent Reports\"
strArea = "Recipients" '..........................................................................................
'Get list of recipients for email
For Each cell In Worksheets("EMails").Range(sRange)
If cell.Value = "" Then GoTo Continue
strmaillist = strmaillist & cell.Value + ";"
Continue:
Next
[B1].Value = strmaillist
If bMyEmail = True Then
strmaillist = strmaillist & MyEmailAddress
End If
'Display email list
Dim AckTime As Integer, InfoBox As Object
Set InfoBox = CreateObject("WScript.Shell")
AckTime = 1
Select Case InfoBox.Popup("Sending " & sReportName & " emails to " & vbNewLine & strArea, _
AckTime, "Message Box", 0)
Case 1, -1
End Select
'SEND EMAIL
'set up Body of email............
strbody = "Please find attached " & sReportName & " Report " & " _" & strDate & vbLf & vbLf & _
strComments & vbLf & _
strComments2 & vbLf & _
"" & vbLf & _
eMailName & vbLf & _
"MI & Performance Reporting Team" & vbLf & _
sline2 & vbLf & _
sline3 & vbLf & vbLf & _
sLine4
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = strmaillist
.CC = ""
.BCC = ""
.Subject = sReportName & " Report " & strDate
.HTMLBody = "Set to HTML" & vbLf & vbLf & ""
.Body = strbody
.Attachments.Add (strfilepath & sTemplateName)
.send ' bugs out here
End With
Set OutMail = Nothing
Set OutApp = Nothing
ThisWorkbook.Activate
Sheets("Sheet1").Select
Application.ScreenUpdating = True: Application.ScreenUpdating = False
Sheets("Sheet1").Select
Range(sRange2).Value = sConclusion '.
Application.ScreenUpdating = True: Application.ScreenUpdating = False
End Sub
You can try to check the validity of the recipient before sending, by using the .Resolve method of the Recipient object. Only valid recipients can be kept in the Recipient list of the mail item.
You might try this:
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Subject = sReportName & " Report " & strDate
.HTMLBody = "Set to HTML" & vbLf & vbLf & ""
.Body = strbody
.Attachments.Add (strfilepath & sTemplateName)
For Each cell In Worksheets("EMails").Range(sRange)
If cell.Value <> "" Then
set r = .Recipients.Add(cell.value)
If Not r.Resolve then r.Delete '<~~ Removes invalid recipients
End If
Next
.send
End With