Hello everyone!
I would greatly appreciate if someone could help me out. So, I have this macro and it emails (using Outlook) the combined header and selected row - so basically it merges two rows and shows it as a merged in the email.
Could someone please help me out what should I do in order not to merge the rows but instead show the header and the selected row as two separate rows in the email (one under another)?
Here is the code:
Sub send_range()
Dim strAddr As String 'string Selected range of cells by user (email address Column Q)
Dim rngAddr As Range 'range of cells by user
Dim strHeader As String 'Column header range
Dim strColumnHeadings As String 'string column heading values
Dim rngHeader As Range 'header
Dim intDollarPosition As Long '$ position in range
Dim intLength As Long 'length of range address ie A1:B2 = 5
Dim strEmailAddressCell As String 'cell location of email address
Dim strEmailAddressValue As String 'value within cell of email address
Dim intMsgBox As Integer 'msgbox integer value
Dim strMsg As String 'message for message box
Dim strTitle As String 'title for message box
Dim strDate As String 'string for date/time
Dim strRowMarker As String 'establish what row needs emailed
Dim strShipTo As String ' Ship to -> Column G
Dim strProduct As String ' Product -> Column H
Dim strRequestDate As String ' Request Date -> Column J
Dim strShipDate As String ' Ship Date -> Column L
Dim strSubject As String 'subject for email string
Dim strAddrOriginal As String 'Original selection cell
Dim strIntroText As String 'introduction text
On Error GoTo ErrHandler 'establish error handler
'make sure there is only one sheet and one selection area and one row chosen
If ActiveWindow.SelectedSheets.Count > 1 _
Or Selection.Areas.Count > 1 _
Or Selection.Rows.Count > 1 Then Exit Sub
'ESTABLISH WHAT CELL SELECTED
strAddr = Selection.Address 'set strAddr = to selection address range
strAddrOriginal = strAddr 'original selected cell
strEmailAddressValue = ActiveSheet.Range(strAddr).Value
'TO GET LAST CELL OF SELECTED RANGE. RECODE TO GET Row Marker from selected cell.
'where last $ is located
intDollarPosition = InStrR(strAddr, "$", 1)
'what row cell selected is in
strRowMarker = Mid$(strAddr, intDollarPosition + 1, (Len(strAddr) - intDollarPosition))
'intLength = Len(strAddr) 'total length of string range
'<<<COMMMENTED OUT WHEN SCOPE CHANGED
'ESTABLISH WHERE EMAIL ADDRESS IS
'get last cell of range and value within it. for email address cell
'strEmailAddressCell = Mid$(strAddr, intColonPosition + 1, intLength)
'strEmailAddressValue = ActiveSheet.Range(strEmailAddressCell).Value
'>>>>>>>> END OF COMMENT
'RECORD VALUES OF PERTINENT FIELDS *** These are hard-codeded if wksheet changes these may
'need to be changed as well ***
strShipTo = ActiveSheet.Range("$G$" & strRowMarker).Value
strProduct = ActiveSheet.Range("$H$" & strRowMarker).Value
strRequestDate = ActiveSheet.Range("$J$" & strRowMarker).Value
strShipDate = ActiveSheet.Range("$L$" & strRowMarker).Value
'subject line of email
strSubject = "RCMS Log at F:\MogadoreOH\Group\Common"
'<<<<< COMMENTED OUT WHEN SCOPE CHANGED
'TO GET LAST CELL OF SELECTED RANGE. RECODE TO GET FROM A COLUMN TO SELECTED CELL COLUMN
'intColonPosition = InStr(strAddr, ":") 'position of : in range
'intLength = Len(strAddr) 'total length of string range
'ESTABLISH WHERE EMAIL ADDRESS IS
'get last cell of range and value within it. for email address cell
'strEmailAddressCell = Mid$(strAddr, intColonPosition + 1, intLength)
'strEmailAddressValue = ActiveSheet.Range(strEmailAddressCell).Value
'ESTABLISH WHAT THE COLUMN HEADINGS ARE FOR THE SELECTED CELLS
'heading range based on the first row of the
'column headings the user selected
'strHeader = "$A$1:$" & CStr(Mid$(strEmailAddressCell, 2, 1)) & "$1"
'>>>>>>>>>> END OF COMMENT
'HEADER IS HARDCODED TO Row 3 and between selected columns A - R.
'Changed to hardcoded column headers.
'strHeader = "$A$1:$" & CStr(Mid$(strAddr, 2, 1)) & "$1"
strHeader = "$A$1:$R$1"
strAddr = "$A$" & strRowMarker & ":" & "$R$" & strRowMarker
Set rngHeader = ActiveSheet.Range(strHeader) 'column heading cells
Set rngAddr = ActiveSheet.Range(strAddr) 'selection cells
'GET INFORMATION INTO CELLS THAT WILL BE SENT VIA EMAIL
'Add column heading texts to selection cells
Call Header_to_range(strAddr, rngAddr, strHeader, rngHeader)
'set selection to be set to selection established by user
ActiveSheet.Range(strAddr).Select
'Show the envelope on the ActiveWorkbook while sending in progress.
ActiveWorkbook.EnvelopeVisible = False
'EMAIL THE CELLS THROUGH OUTLOOK
' Set the optional introduction field thats adds
' some header text to the email body. It also sets
' the To and Subject lines. The name of the file along with
' save time is included. Finally the message is sent.
strDate = Format(Date, "mm-dd-yyyy") & " " & Format(Time, "hh:mm:ss")
strIntroText = "Below is a issue/finding that has been written and assigned to you on the Mogadore RCMS Log. " & _
"Please go to the Log as soon as possible and insert your Estimated Completion Date. " & _
vbCrLf & vbCrLf & _
vbCrLf & vbCrLf & _
"You have 10 days to insert your Estimated Completion Date. This action is tied to an RCMS metric, so if you do not " & _
"comply with this 10 day rule, it will make a negative impact on the metric. " & _
vbCrLf & vbCrLf & _
"Before your Estimated Completion Date comes due, please go to the Log and insert comments in the Root Cause and Completed " & _
"Corrective Action columns, and then alert Jane Uhall by email that it is ready to close." & _
"If you cannot insert comments in these two columns before or on your Estimated Completion date, please " & _
"insert an extension date.--(only one extension date per item is allowed)." & _
vbCrLf & vbCrLf & _
"Thank You"
With ActiveSheet.MailEnvelope
.Introduction = strIntroText
.Item.To = strEmailAddressValue
.Item.Subject = strSubject
.Item.Send
End With
'Hide the envelope on the ActiveWorkbook.
ActiveWorkbook.EnvelopeVisible = False
'RESET EVERYTHING TO ORIGINAL
'set values within selected cells back to original value.
Call Reset_Select_Cells(strAddr, rngAddr)
ActiveSheet.Range(strAddrOriginal).Select
'CONFIRMATION TO USER
'show user email confirmation
strMsg = "Selection sent to " & strEmailAddressValue & "."
strTitle = "Email Information"
intMsgBox = MsgBox(strMsg, vbOKOnly, strTitle)
Exit Sub 'so errhandler is not executed.
'ERROR CATCH IF ANY ERROR OCCURS.
'IGNORE ERROR IF USER DECLINES EMAIL WHILE IN PROGRESS
ErrHandler:
'set selected cell values back to original value
Select Case Err
Case Is = 287
Call Reset_Select_Cells(strAddr, rngAddr)
ActiveSheet.Range(strAddrOriginal).Select
'Hide the envelope on the ActiveWorkbook.
ActiveWorkbook.EnvelopeVisible = False
Case Else
Call Reset_Select_Cells(strAddr, rngAddr)
strMsg = CStr(Error)
strTitle = "Error"
intMsgBox = MsgBox(strMsg, vbOKOnly, strTitle)
ActiveSheet.Range(strAddrOriginal).Select
'Hide the envelope on the ActiveWorkbook.
ActiveWorkbook.EnvelopeVisible = False
End Select
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim anIntVariable As Integer
Dim strMsg As String
Dim strTitle As String
Dim intEmailCell As Integer
'execute as long as one sheet selected, one area is selected,
'one row selected and more than one cell is selected.
If ActiveWindow.SelectedSheets.Count <= 1 _
And Selection.Areas.Count <= 1 _
And Selection.Rows.Count <= 1 _
And Selection.Cells.Count = 1 _
And 2 = InStr(Selection.Address, "F") Then
'last two IF conditional statements added for recode of being able to
'select one cell as long as its email address cell
strMsg = "Would you like to send an email of your selection on save?"
strTitle = "Email Confirmation"
' confirmation that user would like an email sent.
anIntVariable = MsgBox(strMsg, vbYesNo, strTitle)
If anIntVariable = vbYes Then
Call send_range
End If
End If
End Sub
Private Sub Header_to_range(ByRef strAddr As String, ByRef rngAddr As Range, _
ByRef strHeader As String, ByRef rngHeader As Range)
'loop through all column header cells and all select cells.
'if the header cell is in the same column as the selected cell
'concatenate the header cell value with a line return to the selected cell value
'Exit the selected loop. If not continue to loop through selected cell loop
'for that header cell.
For Each rngHeader In ActiveSheet.Range(strHeader)
For Each rngAddr In ActiveSheet.Range(strAddr)
If Left(CStr(rngHeader.Address), 2) = Left(CStr(rngAddr.Address), 2) Then
rngAddr.FormulaR1C1 = rngHeader.Value & Chr(10) & rngAddr.Value
With rngAddr.Characters(Start:=1, Length:=Len(rngHeader.Value)).Font
'.Name = "Arial"
'.FontStyle = "BOLD ITALIC"
'.Size = 9
'.Strikethrough = False
'.Superscript = False
'.Subscript = False
'.OutlineFont = False
'.Shadow = False
'.Underline = xlUnderlineStyleNone
'.ColorIndex = xlAutomatic
End With
Exit For
End If
Next
Next
End Sub
Private Sub Reset_Select_Cells(ByRef strAddr As String, _
ByRef rngAddr As Range)
Dim StartPosition As Long
For Each rngAddr In ActiveSheet.Range(strAddr)
'find position of chr10 (soft return) in cell formula. Everything before chr10
'is column header information. Overwrite selected cell with just original
'selected cell information. Make sure font is arial and standard, no bold.
StartPosition = InStr(rngAddr.FormulaR1C1, Chr(10)) + 1 'position of 'chr10' in range
rngAddr.Value = Mid$((rngAddr.Value), StartPosition, Len(rngAddr.Value))
With rngAddr.Characters(Start:=1, Length:=Len(rngAddr.Value)).Font
'.Name = "Arial"
'.FontStyle = "standard"
'.Size = 10
'.Strikethrough = False
'.Superscript = False
'.Subscript = False
'.OutlineFont = False
'.Shadow = False
'.Underline = xlUnderlineStyleNone
'.ColorIndex = xlAutomatic
End With
Next
End Sub
Function InStrR(ByVal sTarget As String, _
ByVal sFind As String, _
ByVal iCompare As Long) As Long
Dim P As Long, LastP As Long, Start As Long
'Finds last occurance of sFind in sTarget.
'iCompare can be binary solution, position etc.
P = InStr(1, sTarget, sFind, iCompare)
Do While P
LastP = P
P = InStr(LastP + 1, sTarget, sFind, iCompare)
Loop
InStrR = LastP
End Function
I would greatly appreciate if someone could help me out. So, I have this macro and it emails (using Outlook) the combined header and selected row - so basically it merges two rows and shows it as a merged in the email.
Could someone please help me out what should I do in order not to merge the rows but instead show the header and the selected row as two separate rows in the email (one under another)?
Here is the code:
Sub send_range()
Dim strAddr As String 'string Selected range of cells by user (email address Column Q)
Dim rngAddr As Range 'range of cells by user
Dim strHeader As String 'Column header range
Dim strColumnHeadings As String 'string column heading values
Dim rngHeader As Range 'header
Dim intDollarPosition As Long '$ position in range
Dim intLength As Long 'length of range address ie A1:B2 = 5
Dim strEmailAddressCell As String 'cell location of email address
Dim strEmailAddressValue As String 'value within cell of email address
Dim intMsgBox As Integer 'msgbox integer value
Dim strMsg As String 'message for message box
Dim strTitle As String 'title for message box
Dim strDate As String 'string for date/time
Dim strRowMarker As String 'establish what row needs emailed
Dim strShipTo As String ' Ship to -> Column G
Dim strProduct As String ' Product -> Column H
Dim strRequestDate As String ' Request Date -> Column J
Dim strShipDate As String ' Ship Date -> Column L
Dim strSubject As String 'subject for email string
Dim strAddrOriginal As String 'Original selection cell
Dim strIntroText As String 'introduction text
On Error GoTo ErrHandler 'establish error handler
'make sure there is only one sheet and one selection area and one row chosen
If ActiveWindow.SelectedSheets.Count > 1 _
Or Selection.Areas.Count > 1 _
Or Selection.Rows.Count > 1 Then Exit Sub
'ESTABLISH WHAT CELL SELECTED
strAddr = Selection.Address 'set strAddr = to selection address range
strAddrOriginal = strAddr 'original selected cell
strEmailAddressValue = ActiveSheet.Range(strAddr).Value
'TO GET LAST CELL OF SELECTED RANGE. RECODE TO GET Row Marker from selected cell.
'where last $ is located
intDollarPosition = InStrR(strAddr, "$", 1)
'what row cell selected is in
strRowMarker = Mid$(strAddr, intDollarPosition + 1, (Len(strAddr) - intDollarPosition))
'intLength = Len(strAddr) 'total length of string range
'<<<COMMMENTED OUT WHEN SCOPE CHANGED
'ESTABLISH WHERE EMAIL ADDRESS IS
'get last cell of range and value within it. for email address cell
'strEmailAddressCell = Mid$(strAddr, intColonPosition + 1, intLength)
'strEmailAddressValue = ActiveSheet.Range(strEmailAddressCell).Value
'>>>>>>>> END OF COMMENT
'RECORD VALUES OF PERTINENT FIELDS *** These are hard-codeded if wksheet changes these may
'need to be changed as well ***
strShipTo = ActiveSheet.Range("$G$" & strRowMarker).Value
strProduct = ActiveSheet.Range("$H$" & strRowMarker).Value
strRequestDate = ActiveSheet.Range("$J$" & strRowMarker).Value
strShipDate = ActiveSheet.Range("$L$" & strRowMarker).Value
'subject line of email
strSubject = "RCMS Log at F:\MogadoreOH\Group\Common"
'<<<<< COMMENTED OUT WHEN SCOPE CHANGED
'TO GET LAST CELL OF SELECTED RANGE. RECODE TO GET FROM A COLUMN TO SELECTED CELL COLUMN
'intColonPosition = InStr(strAddr, ":") 'position of : in range
'intLength = Len(strAddr) 'total length of string range
'ESTABLISH WHERE EMAIL ADDRESS IS
'get last cell of range and value within it. for email address cell
'strEmailAddressCell = Mid$(strAddr, intColonPosition + 1, intLength)
'strEmailAddressValue = ActiveSheet.Range(strEmailAddressCell).Value
'ESTABLISH WHAT THE COLUMN HEADINGS ARE FOR THE SELECTED CELLS
'heading range based on the first row of the
'column headings the user selected
'strHeader = "$A$1:$" & CStr(Mid$(strEmailAddressCell, 2, 1)) & "$1"
'>>>>>>>>>> END OF COMMENT
'HEADER IS HARDCODED TO Row 3 and between selected columns A - R.
'Changed to hardcoded column headers.
'strHeader = "$A$1:$" & CStr(Mid$(strAddr, 2, 1)) & "$1"
strHeader = "$A$1:$R$1"
strAddr = "$A$" & strRowMarker & ":" & "$R$" & strRowMarker
Set rngHeader = ActiveSheet.Range(strHeader) 'column heading cells
Set rngAddr = ActiveSheet.Range(strAddr) 'selection cells
'GET INFORMATION INTO CELLS THAT WILL BE SENT VIA EMAIL
'Add column heading texts to selection cells
Call Header_to_range(strAddr, rngAddr, strHeader, rngHeader)
'set selection to be set to selection established by user
ActiveSheet.Range(strAddr).Select
'Show the envelope on the ActiveWorkbook while sending in progress.
ActiveWorkbook.EnvelopeVisible = False
'EMAIL THE CELLS THROUGH OUTLOOK
' Set the optional introduction field thats adds
' some header text to the email body. It also sets
' the To and Subject lines. The name of the file along with
' save time is included. Finally the message is sent.
strDate = Format(Date, "mm-dd-yyyy") & " " & Format(Time, "hh:mm:ss")
strIntroText = "Below is a issue/finding that has been written and assigned to you on the Mogadore RCMS Log. " & _
"Please go to the Log as soon as possible and insert your Estimated Completion Date. " & _
vbCrLf & vbCrLf & _
vbCrLf & vbCrLf & _
"You have 10 days to insert your Estimated Completion Date. This action is tied to an RCMS metric, so if you do not " & _
"comply with this 10 day rule, it will make a negative impact on the metric. " & _
vbCrLf & vbCrLf & _
"Before your Estimated Completion Date comes due, please go to the Log and insert comments in the Root Cause and Completed " & _
"Corrective Action columns, and then alert Jane Uhall by email that it is ready to close." & _
"If you cannot insert comments in these two columns before or on your Estimated Completion date, please " & _
"insert an extension date.--(only one extension date per item is allowed)." & _
vbCrLf & vbCrLf & _
"Thank You"
With ActiveSheet.MailEnvelope
.Introduction = strIntroText
.Item.To = strEmailAddressValue
.Item.Subject = strSubject
.Item.Send
End With
'Hide the envelope on the ActiveWorkbook.
ActiveWorkbook.EnvelopeVisible = False
'RESET EVERYTHING TO ORIGINAL
'set values within selected cells back to original value.
Call Reset_Select_Cells(strAddr, rngAddr)
ActiveSheet.Range(strAddrOriginal).Select
'CONFIRMATION TO USER
'show user email confirmation
strMsg = "Selection sent to " & strEmailAddressValue & "."
strTitle = "Email Information"
intMsgBox = MsgBox(strMsg, vbOKOnly, strTitle)
Exit Sub 'so errhandler is not executed.
'ERROR CATCH IF ANY ERROR OCCURS.
'IGNORE ERROR IF USER DECLINES EMAIL WHILE IN PROGRESS
ErrHandler:
'set selected cell values back to original value
Select Case Err
Case Is = 287
Call Reset_Select_Cells(strAddr, rngAddr)
ActiveSheet.Range(strAddrOriginal).Select
'Hide the envelope on the ActiveWorkbook.
ActiveWorkbook.EnvelopeVisible = False
Case Else
Call Reset_Select_Cells(strAddr, rngAddr)
strMsg = CStr(Error)
strTitle = "Error"
intMsgBox = MsgBox(strMsg, vbOKOnly, strTitle)
ActiveSheet.Range(strAddrOriginal).Select
'Hide the envelope on the ActiveWorkbook.
ActiveWorkbook.EnvelopeVisible = False
End Select
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim anIntVariable As Integer
Dim strMsg As String
Dim strTitle As String
Dim intEmailCell As Integer
'execute as long as one sheet selected, one area is selected,
'one row selected and more than one cell is selected.
If ActiveWindow.SelectedSheets.Count <= 1 _
And Selection.Areas.Count <= 1 _
And Selection.Rows.Count <= 1 _
And Selection.Cells.Count = 1 _
And 2 = InStr(Selection.Address, "F") Then
'last two IF conditional statements added for recode of being able to
'select one cell as long as its email address cell
strMsg = "Would you like to send an email of your selection on save?"
strTitle = "Email Confirmation"
' confirmation that user would like an email sent.
anIntVariable = MsgBox(strMsg, vbYesNo, strTitle)
If anIntVariable = vbYes Then
Call send_range
End If
End If
End Sub
Private Sub Header_to_range(ByRef strAddr As String, ByRef rngAddr As Range, _
ByRef strHeader As String, ByRef rngHeader As Range)
'loop through all column header cells and all select cells.
'if the header cell is in the same column as the selected cell
'concatenate the header cell value with a line return to the selected cell value
'Exit the selected loop. If not continue to loop through selected cell loop
'for that header cell.
For Each rngHeader In ActiveSheet.Range(strHeader)
For Each rngAddr In ActiveSheet.Range(strAddr)
If Left(CStr(rngHeader.Address), 2) = Left(CStr(rngAddr.Address), 2) Then
rngAddr.FormulaR1C1 = rngHeader.Value & Chr(10) & rngAddr.Value
With rngAddr.Characters(Start:=1, Length:=Len(rngHeader.Value)).Font
'.Name = "Arial"
'.FontStyle = "BOLD ITALIC"
'.Size = 9
'.Strikethrough = False
'.Superscript = False
'.Subscript = False
'.OutlineFont = False
'.Shadow = False
'.Underline = xlUnderlineStyleNone
'.ColorIndex = xlAutomatic
End With
Exit For
End If
Next
Next
End Sub
Private Sub Reset_Select_Cells(ByRef strAddr As String, _
ByRef rngAddr As Range)
Dim StartPosition As Long
For Each rngAddr In ActiveSheet.Range(strAddr)
'find position of chr10 (soft return) in cell formula. Everything before chr10
'is column header information. Overwrite selected cell with just original
'selected cell information. Make sure font is arial and standard, no bold.
StartPosition = InStr(rngAddr.FormulaR1C1, Chr(10)) + 1 'position of 'chr10' in range
rngAddr.Value = Mid$((rngAddr.Value), StartPosition, Len(rngAddr.Value))
With rngAddr.Characters(Start:=1, Length:=Len(rngAddr.Value)).Font
'.Name = "Arial"
'.FontStyle = "standard"
'.Size = 10
'.Strikethrough = False
'.Superscript = False
'.Subscript = False
'.OutlineFont = False
'.Shadow = False
'.Underline = xlUnderlineStyleNone
'.ColorIndex = xlAutomatic
End With
Next
End Sub
Function InStrR(ByVal sTarget As String, _
ByVal sFind As String, _
ByVal iCompare As Long) As Long
Dim P As Long, LastP As Long, Start As Long
'Finds last occurance of sFind in sTarget.
'iCompare can be binary solution, position etc.
P = InStr(1, sTarget, sFind, iCompare)
Do While P
LastP = P
P = InStr(LastP + 1, sTarget, sFind, iCompare)
Loop
InStrR = LastP
End Function
