Flora Edwards
asked on
VBA challenge how can i change this VBA so that returned data is also in form of table
Please see attached workbook.
my macro below generates a messed up data.
i pasted the code from the debug.print result below.
Barry, Tanisha H. 856-6314 Est Rd. 16860817 3293 3131
Bray, Dolan P. P.O. Box 924, 7221 Quam. Street 16030817 0315 5617
Burgess, Zachary T. Ap #291-9685 Neque Rd. 16260625 5772 6250
Church, Hashim Y. 9475 Nam Street 16980902 6462 4558
Donovan, Larissa S. 1938 Eleifend Rd. 16810715 0982 2576
Fuller, Driscoll J. 8277 Parturient Rd. 16100529 7864 2894
Gross, Benjamin N. Ap #193-5551 Tellus, Ave 16531218 3428 7492
Hensley, Tatyana N. 883-7830 Suspendisse St. 16021113 4838 2939
Henson, Dara P. P.O. Box 390, 1770 Non Av. 16941110 7593 5157
Henson, Xavier Z. Ap #680-9938 Convallis Avenue 16820915 8024 7082
Hughes, Reese J. Ap #340-959 Et Av. 16450426 3015 6176
Jacobs, Gareth C. P.O. Box 199, 2762 Non, Rd. 16301125 7528 8820
Kane, Maia U. 642-625 Tempor Rd. 16161203 2985 7006
Lewis, Guinevere W. Ap #718-4418 Nunc Rd. 16440225 9545 3795
Malone, Rowan V. 6790 Eu Street 16240221 4189 9376
Nieves, Stacey K. 5601 Orci. Road 16860623 6670 2696
Stark, Eliana C. 595-3843 Ipsum Street 16740706 6237 8688
Turner, Fulton J. 3725 Sollicitudin Rd. 16390226 1944 6370
Tyson, Kameko S. Ap #549-1934 Iaculis Avenue 16421028 8330 2301
because i am passing this result to an outlook email, i need the result to be like it is shown in the screenshot below.
Book1.xlsb
my macro below generates a messed up data.
i pasted the code from the debug.print result below.
Sub test()
With ThisWorkbook
Set ISONUMBER = .Worksheets("Sheet1").ListObjects("Table1")
With ISONUMBER
For Each rngCell In .DataBodyRange.Columns(1).Cells
If rngCell(1, 3).Value & rngCell(1, 10).Value = "MatchedTrue" Then
StringList = StringList & vbLf & rngCell(1, 1).Value & " " & rngCell(1, 5).Value _
& " " & rngCell(1, 11).Value & " " & rngCell(1, 9).Value
End If
Next rngCell
End With
End With
Debug.Print StringList
End Sub
Barry, Tanisha H. 856-6314 Est Rd. 16860817 3293 3131
Bray, Dolan P. P.O. Box 924, 7221 Quam. Street 16030817 0315 5617
Burgess, Zachary T. Ap #291-9685 Neque Rd. 16260625 5772 6250
Church, Hashim Y. 9475 Nam Street 16980902 6462 4558
Donovan, Larissa S. 1938 Eleifend Rd. 16810715 0982 2576
Fuller, Driscoll J. 8277 Parturient Rd. 16100529 7864 2894
Gross, Benjamin N. Ap #193-5551 Tellus, Ave 16531218 3428 7492
Hensley, Tatyana N. 883-7830 Suspendisse St. 16021113 4838 2939
Henson, Dara P. P.O. Box 390, 1770 Non Av. 16941110 7593 5157
Henson, Xavier Z. Ap #680-9938 Convallis Avenue 16820915 8024 7082
Hughes, Reese J. Ap #340-959 Et Av. 16450426 3015 6176
Jacobs, Gareth C. P.O. Box 199, 2762 Non, Rd. 16301125 7528 8820
Kane, Maia U. 642-625 Tempor Rd. 16161203 2985 7006
Lewis, Guinevere W. Ap #718-4418 Nunc Rd. 16440225 9545 3795
Malone, Rowan V. 6790 Eu Street 16240221 4189 9376
Nieves, Stacey K. 5601 Orci. Road 16860623 6670 2696
Stark, Eliana C. 595-3843 Ipsum Street 16740706 6237 8688
Turner, Fulton J. 3725 Sollicitudin Rd. 16390226 1944 6370
Tyson, Kameko S. Ap #549-1934 Iaculis Avenue 16421028 8330 2301
because i am passing this result to an outlook email, i need the result to be like it is shown in the screenshot below.
Book1.xlsb
SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
i have a UDF that passes the StringList into outlook body.you may probably store the content in clipboard and paste it into your outlook mail body, just a thought...
try to share codes with us here so we can give further comments
ASKER
Ryan,
here is the rest of the code.
here is the rest of the code.
Function SendMessage(strTo As String, Optional strCC As String, Optional strBCC As String, Optional strSubject As String, Optional strMessage As String, Optional rngToCopy As Range, Optional strAttachmentPath As String, Optional blnShowEmailBodyWithoutSending As Boolean = False, Optional blnSignature As Boolean)
Dim objOutlook As Object 'Outlook.Application
Dim objOutlookMsg As Object 'Outlook.MailItem
Dim objOutlookRecip As Object 'Outlook.Recipient
Dim objOutlookAttach As Object 'Outlook.Attachment
Dim lngLoop As Long
Dim strSignature As String
If Trim(strTo) & Trim(strCC) & Trim(strBCC) = "" Then
MsgBox "Please provide a mailing address!", vbInformation + vbOKOnly, "Missing mail information"
Exit Function
End If
'Create the Outlook session.
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application." & Val(Application.Version))
Err.Clear: On Error GoTo -1: On Error GoTo 0
If objOutlook Is Nothing Then
Set objOutlook = CreateObject("Outlook.Application." & Val(Application.Version))
End If
'Create the message.
Set objOutlookMsg = objOutlook.CreateItem(0)
With objOutlookMsg
'Add the To recipient(s) to the message.
For lngLoop = LBound(Split(strTo, ";")) To UBound(Split(strTo, ";"))
If Trim(Split(strTo, ";")(lngLoop)) <> "" Then
Set objOutlookRecip = .Recipients.Add(Trim(Split(strTo, ";")(lngLoop)))
objOutlookRecip.Type = 1 'olTO
End If
Next lngLoop
'Add the CC recipient(s) to the message.
For lngLoop = LBound(Split(strCC, ";")) To UBound(Split(strCC, ";"))
If Trim(Split(strCC, ";")(lngLoop)) <> "" Then
Set objOutlookRecip = .Recipients.Add(Trim(Split(strCC, ";")(lngLoop)))
objOutlookRecip.Type = 2 'olCC
End If
Next lngLoop
'Add the BCC recipient(s) to the message.
For lngLoop = LBound(Split(strBCC, ";")) To UBound(Split(strBCC, ";"))
If Trim(Split(strBCC, ";")(lngLoop)) <> "" Then
Set objOutlookRecip = .Recipients.Add(Trim(Split(strBCC, ";")(lngLoop)))
objOutlookRecip.Type = 3 'olBCC
End If
Next lngLoop
'Set the Subject, Body, and Importance of the message.
If strSubject = "" Then
strSubject = "This is an Automation test with Microsoft Outlook"
End If
.Subject = strSubject
If strMessage = "" Then
strMessage = "This is the body of the message." & vbCrLf & vbCrLf
End If
.Importance = 2 'High importance
If Not strMessage = "" Then
.Body = strMessage & vbCrLf & vbCrLf
End If
If Not rngToCopy Is Nothing Then
.HTMLBody = .Body & RangetoHTML(rngToCopy)
End If
'Add attachments to the message.
For lngLoop = LBound(Split(strAttachmentPath, "|")) To UBound(Split(strAttachmentPath, "|"))
If Not strAttachmentPath = "" Then
If Len(Dir(Trim(Split(strAttachmentPath, "|")(lngLoop)))) <> 0 Then
Set objOutlookAttach = .Attachments.Add(Trim(Split(strAttachmentPath, "|")(lngLoop)))
Else
MsgBox "Unable to find the specified attachment '" & Trim(Split(strAttachmentPath, "|")(lngLoop)) & "'. Sending mail anyway."
End If
End If
Next lngLoop
If blnSignature Then
'Win XP
strSignature = Environ("USERPROFILE") & "\Application Data\Microsoft\Signatures\*.htm"
strSignature = Environ("USERPROFILE") & "\Application Data\Microsoft\Signatures\" & Dir(strSignature)
If Dir(strSignature) = "" Then
'Win 7
strSignature = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures\*.htm"
strSignature = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures\" & Dir(strSignature)
End If
End If
If Dir(strSignature) <> "" Then
strSignature = GetBoiler(strSignature)
Else
strSignature = ""
End If
'MsgBox .htmlbody
.HTMLBody = .HTMLBody & strSignature
'Resolve each Recipient's name.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
Next
'Should we display the message before sending?
If blnShowEmailBodyWithoutSending Then
.Display
Else
.Display
.Save
.Send
End If
End With
Set objOutlook = Nothing
Set objOutlookMsg = Nothing
Set objOutlookAttach = Nothing
Set objOutlookRecip = Nothing
End Function
Function RangetoHTML(rng As Range)
'Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
Dim strTempFile As String
Dim wbkTemp As Workbook
strTempFile = Environ$("temp") & Application.PathSeparator & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a workbook to receive the data.
rng.Copy
Set wbkTemp = Workbooks.Add(1)
With wbkTemp.Sheets(1)
With .Cells(1)
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues, , False, False
.PasteSpecial xlPasteFormats, , False, False
.Select
End With
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
Err.Clear: On Error GoTo 0
End With
'Publish the sheet to an .htm file.
With wbkTemp.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=strTempFile, _
Sheet:=wbkTemp.Sheets(1).Name, _
Source:=wbkTemp.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the .htm file into the RangetoHTML subroutine.
RangetoHTML = GetBoiler(strTempFile)
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close wbkTemp
wbkTemp.Close savechanges:=False
'Delete the htm file.
Kill strTempFile
Set wbkTemp = Nothing
End Function
Function GetBoiler(ByVal strFile As String) As String
'May not be supported in MAC
Dim objFSO As Object
Dim objTextStream As Object
On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextStream = objFSO.GetFile(strFile).OpenAsTextStream(1, -2)
GetBoiler = objTextStream.ReadAll
objTextStream.Close
Set objFSO = Nothing
Set objTextStream = Nothing
End Function
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Many thanks
ASKER
thanks a lot.
i have a UDF that passes the StringList into outlook body.
how am i going to use the helper range into body of that email?