LinkBack URL
About LinkBacks
Hello! I am still looking for help with this code!
I've searched for how to do this, including on Ron De Bruin's website, and have yet to see how you can copy a range of cells in Excel from a file into the body of an email that already has text plus attach a separate file to the email. I'm sure it's doable, but I'm way too new at all of this to figure out the correct code to use.
The cells that need to be copied will always be in a file named SPSS CHECK--Daily ER Production Aggr by Region Type & ER.xlsx in columns A-K, but the number of rows in that range will vary by day. I've identified where I'd want these cells to be pasted in the code below, but with no attempt at coming up with the code for that.
BTW, is there a way to add a hard space at the end of sentences so that two spaces always appear between the end of one sentence and the beginning of another, or is that an Outlook quirk that strips out extra spaces and reformats the text?
Here is my code so far:
Sub SaveToDir() ActiveWorkbook.Save Dim wbk As Workbook SaveDir = "F:\GroupShares\Employer Activity by Day\" 'See if today's date (Now) is a Monday or not. If Monday, it runs the first SaveName code; otherwise, it runs the second SaveName code. If (Weekday(Now(), 2) = 1) Then SaveName = "Daily Employer Production by Region, Manager, & Agent Report--" & Format(Now() - 3, "YYYY-MM-DD") & ".xlsx" Else SaveName = "Daily Employer Production by Region, Manager, & Agent Report--" & Format(Now() - 1, "YYYY-MM-DD") & ".xlsx" End If If Len(Dir(SaveDir & SaveName, vbDirectory)) > 0 Then 'Check to see if the file already exists Resp = MsgBox("File name: " & SaveName & vbCrLf & vbCrLf & "already exists in: " & vbCrLf & vbCrLf & SaveDir & vbCrLf & vbCrLf & "Press Okay to continue, Cancel to abort", vbOKCancel) If Resp = vbCancel Then Exit Sub End If For Each wbk In Workbooks 'Check to see if the file is open If wbk.Name = SaveName Then Resp2 = MsgBox(SaveName & " is open. Press OK to close the file or Cancel to abort", vbOKCancel) If Resp2 = vbOK Then Application.DisplayAlerts = False Workbooks(SaveName).Close Else Exit Sub End If End If Next End If ActiveWorkbook.Sheets.Copy 'Copy all sheets to a new workbook with no code modules Set wbk = ActiveWorkbook 'Copied sheets in the new workbook Application.DisplayAlerts = False wbk.Sheets("Sheet1").Delete wbk.SaveAs Filename:=SaveDir & SaveName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 'Saves the new file MsgBox ("File name: " & SaveName & vbCrLf & vbCrLf & "has been saved to " & vbCrLf & vbCrLf & SaveDir) Workbooks.Open Filename:="F:\GroupShares\Employer Activity by Day\SPSS CHECK--Daily ER Production Aggr by Region Type & ER.xlsx" Range("A1").Select Range(Selection, Selection.End(xlDown)).Select Range(Selection, Selection.End(xlToRight)).Select With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .Weight = xlThin End With With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .Weight = xlThin End With Selection.Copy Dim OutApp As Object Dim OutMail As Object Dim strbody As String Workbooks(SaveName).Activate Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) strbody = "<HTML><BODY><p style='font-family:calibri;font-size:14.5'>" & "Hi, <br><br>" & _ "Here is the Daily Employer Production report for " & Application.Text(ActiveSheet.Range("D1"), "mmmm d, yyyy") & _ ". " & " A summary of the production is below: <br><br>" & _ '***********This is where I want the pasted cells from the file to go.**************** "If you have any questions regarding the accuracy of this report, please check to be sure numbers were entered correctly. " & _ " If there are still problems, please contact me. <br><br>" & _ "Thanks,<br><br>Bryan<br></p>" On Error Resume Next With OutMail .to = "Person@MyDomain.com" .Subject = "Daily Employer Production Report for " & Application.Text(ActiveSheet.Range("D1"), "M/D/YYYY") .HTMLbody = strbody & .HTMLbody .Attachments.Add ActiveWorkbook.FullName .Display 'or use .Send End With On Error GoTo 0 Set OutMail = Nothing Set OutApp = Nothing Application.DisplayAlerts = True End Sub
Register To Reply
Bookmarks