Export Cells to Email based off range of dates using VBA
Question
Hello Stackoverflow Community!
I'm completely new to VBA and I'm having some issues.
So I'm trying to export excel cells to an email within a specific date range. The program asks the user to enter the start date and the end date. The program then scans the excel sheet and pulls the data that either falls within the date range, or falls on the selected day(s). The data from the excel sheet is placed in a temporary workbook then from the temp work book - the data is then copied to an outlook email. The temp workbook is then deleted.
Please bear with me - being new to VBA my code is a little all over the place. I've been trying many solutions from the internet but they have not been working in my favor. The email opens up correctly with all the pre-filled HTML data (not included in the code below), but none of the data from the excel cells are there. I know that my function RangeToHtml needs some re-working. Any tips to point me in the right direction will be greatly appreciated!
Sub CommandButton4_Click()
Dim newdate
newdate = Date
Dim rng As Range
Set rng = Nothing
Dim i As Integer
newdate = Date - 6
Set rng = Sheets("Sheet1").Range("A2").SpecialCells(xlCellTypeVisible)
If rng Is Nothing Then
MsgBox " The selection is not a range or the sheet is protected." & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set oLook = CreateObject("Outlook.Application")
Set oMail = oLook.CreateItem(oMailItem)
ActiveWorkbook.EnvelopeVisible = True
Dim strA As String, strB As String, strVerify As String
'Set Variable Values
strA = "You're about to send the weekely OEM PPM Newsletter Update."
strB = "Are you sure you want to send the mail?"
strVerify = strA & vbNewLine & strB
' Set the optional introduction field thats adds
' some header text to the email body. It also sets
' the To and Subject lines. Finally the message
' is sent.
' Attaching the Header to the email'
Const MyPath = "C:\Users\Jalexan1\Pictures\HEADER.jpg"
Const MyPicture = "HEADER.jpg"
With oMail
.Subject = "WW OEM Weekly Update " & Date - 7 & " - " & Date
.To = "some email@email.com"
.Attachments.Add "C:\Users\Jalexan1\Pictures\HEADER.jpg"
.HTMLBody = RangetoHTML(rng) & "<html>" & "<img src=cid:" & Replace(MyPicture, " ", "%20") & " height=200 width=980>" "</html>"
'.Body = "WW OEM PPM WEEKELY UPDATE" & Date
.Display
End With
End If
Set oMail = Nothing
Set oLook = Nothing
End Sub
Function RangetoHTML(rng As Range)
Dim rowcout As Long
'rowcout = Cells(Rows.Count, "A").End(xlUp).Row'
Dim sh As Worksheet
Dim rn As Range
Set sh = ThisWorkbook.Sheets("Sheet1")
Dim LastRow As Long
Set rn = sh.UsedRange
LastRow = rn.Rows.Count + rn.Row - 1
Dim startdate As Date, enddate As Date
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
Dim c As Range
startdate = CDate(InputBox("Enter a Start Date in the format of MM/DD/YYY : "))
enddate = CDate(InputBox("End Date: "))
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'copy the range and create a new workbook to paste the data into'
'LastRow = ActiveSheet.Range(“A” & Rows.Count).End(xlUp).Row
rng.Copy
Set TempWB = Workbooks.Add(1)
For i = 2 To LastRow
Dim cellcheck As Date
datecheck = Range("A" & i).Value
If datecheck >= startdate & datecheck <= enddate Then
Set TempWB = Workbooks.Add(1)
rng = Range(("A" & i)).Value
MsgBox (rangerange)
rng.Copy
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteValues, , False, False
Cells(1).Select
Application.CutCopyMode = False
'.DrawingObjects.Visible = True
'.DrawingObjects.Delete
' On Error GoTo 0
End With
End If
Exit For
Next i
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsources=", _
"slign=left x:publishsource=")
'close temp wb'
TempWB.Close savechanges = False
'Delete the temp file'
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
1 answers
solution1
0 2015-06-08 20:43:57
The problem is that you are looking at cell "A2104856" which doesn't exist instead of cell "A1048576." (Obviously this depends on which version of excel you are using, but either way, it is looking at a cell beyond the biggest possible row)
Try this:
LastRow = ActiveSheet.Range(“A” & Rows.Count).End(xlUp).Row
and remove the "2" from "A2" & Rows.Count
The ampersand means to concatenate the string to the end of the previous one, not move down to the end of the column, so "A2" & "15" = "A215"
EDIT: This seems to have fixed the original problem, but there is another problem you have mentioned in the comments.
I noticed a misspelling in this line:
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsources=", _
"slign=left x:publishsource=")
"align" has been misspelled "slign".
UPdate this to:
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsources=", _
"align=left x:publishsource=")
However, as a general word of advice, if something is not giving you the output you desire (even if no errors are being thrown), the best first step is to step through the code and verify that each step in the code is doing what you want.
I don't know for sure that this is the only issue, and I'm not sure it would even create a blank email (it seems more likely to me that it would create one with strange formatting, but I haven't tested it), but if you step through this function, you will be able to see where it is going wrong.
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.