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.



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

Open in new window

     

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.

E1.pngBook1.xlsb
LVL 6
FloraAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Ryan ChongBusiness Systems Analyst , ex-Senior Application EngineerCommented:
try this, in which you got to format it in cell format not just plain text.

Sub test()
    Dim ws As Worksheet, row As Integer
    
    With ThisWorkbook
    
        'Add a new worksheet
        Set ws = .Sheets.Add(After:=Sheets(Sheets.Count), Count:=1, Type:=xlWorksheet)
        ws.Cells(1, "A") = "Names"
        ws.Cells(1, "B") = "Street"
        ws.Cells(1, "C") = "SSN"
        ws.Cells(1, "D") = "PIN"
        row = 2
        
        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
                    ws.Cells(row, "A") = rngCell(1, 1).Value
                    ws.Cells(row, "B") = rngCell(1, 5).Value
                    ws.Cells(row, "C") = rngCell(1, 11).Value
                    ws.Cells(row, "D") = rngCell(1, 9).Value
                    row = row + 1
                End If
            Next rngCell
        End With
        
        Columns("A:D").EntireColumn.AutoFit
    End With
End Sub

Open in new window

0
FloraAuthor Commented:
Ryan Chong

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?
0
Ryan ChongBusiness Systems Analyst , ex-Senior Application EngineerCommented:
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
0
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

FloraAuthor Commented:
Ryan,

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

Open in new window

0
ProfessorJimJamMicrosoft Excel ExpertCommented:
try this.


Sub test()
    Dim ws As Worksheet, row As Integer
    
    With ThisWorkbook
    
        'Add a new worksheet
        Set ws = .Sheets("helper")
        ws.Cells.Clear
        ws.Cells(1, "A") = "Names"
        ws.Cells(1, "B") = "Street"
        ws.Cells(1, "C") = "SSN"
        ws.Cells(1, "D") = "PIN"
        row = 2
        
        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
                    ws.Cells(row, "A") = rngCell(1, 1).Value
                    ws.Cells(row, "B") = rngCell(1, 5).Value
                    ws.Cells(row, "C") = rngCell(1, 11).Value
                    ws.Cells(row, "D") = rngCell(1, 9).Value
                    row = row + 1
                End If
            Next rngCell
        End With
        
        ws.Columns("A:D").EntireColumn.AutoFit
        ws.UsedRange.Borders.LineStyle = xlContinuous
        
        SendMessage "youremail@yourdomain", , , "Subject is this one", , ws.UsedRange
    End With
End Sub

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

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
FloraAuthor Commented:
Many thanks
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VBA

From novice to tech pro — start learning today.