JoinRange Update

I use the heck out the JoinRange function I wrote a few years back. The vast majority of the time I’m using it for two purposes: creating a table in a Trac wiki page or creating an HTML table. I’ve been typing those same delimiters over and over and it has to stop.

I add an optional sMacro argument as the first argument. I can fill this argument with some predefined terms and it will create the necessary delimiters. And as long as I was in there, I change the range looping to array looping. Here’s what it looks like now.

'---------------------------------------------------------------------------------------
' Procedure : JoinRange
' Author    : dick
' Date      : 3/31/2012
' Purpose   : Concatenate cell values with delimiters and line ends
' Args      : sMacro - preset delimeters, overrides other arguments
'             sDelim - text inserted between cell values
'             sLinestart - text inserted before the first cell value
'             sLineEnd - text inserted after the last cell value
'             sBlank - text used instead of nothing for blank cells
'---------------------------------------------------------------------------------------
'
Public Function JoinRange(rInput As Range, _
    Optional sMacro As String = "", _
    Optional sDelim As String = "", _
    Optional sLineStart As String = "", _
    Optional sLineEnd As String = "", _
    Optional sBlank As String = "") As String
   
    Dim sReturn As String
    Dim vaValues As Variant
    Dim i As Long, j As Long
   
    Select Case UCase(sMacro)
        Case "HTMLTABLE", "HTML TABLE"
            sDelim = "</td><td>"
            sLineStart = "<tr><td>"
            sLineEnd = "</td></tr>"
        Case "TRACTABLE", "TRAC", "TRAC TABLE"
            sDelim = "||"
            sLineStart = "||"
            sLineEnd = "||"
    End Select
   
    vaValues = rInput.Value
    sReturn = sLineStart
   
    For i = LBound(vaValues, 1) To UBound(vaValues, 1)
        For j = LBound(vaValues, 2) To UBound(vaValues, 2)
            If Len(vaValues(i, j)) = 0 Then
               sReturn = sReturn & sBlank & sDelim
            Else
                sReturn = sReturn & vaValues(i, j) & sDelim
            End If
        Next j
    Next i
   
    sReturn = Left$(sReturn, Len(sReturn) - Len(sDelim))
   
    sReturn = sReturn & sLineEnd
   
    JoinRange = sReturn
   
End Function

Abigail Taylor Coral Springs
Bryan Burns Charlotte
Trinity Wallace Clarksville
Arianna Reynolds Elizabeth
Gabriella Roberts Providence
Katherine Foster Miami
Megan Hunt Toledo
Diego Black Garland

Oh, I’m going to save so much typing.

2 Comments

  1. Michael says:

    Hi Dick –

    Presuming the joined range is destined for display in other software, should you make it a data object and put it in the clipboard? Save those mouse clicks and paste in one swell foop.

    … mrt

  2. Tushar Mehta says:

    Nice, though I suspect the HTML code needs a tweak. For a multi-row range, shouldn’t the LineStart and LineEnd tokens be added to the HTML for each row? Currently, they are added only once for the entire range.

    I made that change, and also added the option of a header row (the option Hdr parameter). If present, this will create a row with TH tags. Also, one can request html code with the sMacro=”HTML”

    I also added an option for XML (sMacro=”XML”). In this case, one must specify a ‘Entity ID’ that is used as the XML wrapper for each row (the parameter EntityID). In addition, one must specify a header row. This can be either through the Hdr parameter or, if missing, row 1 of a multi-row range.

    To ensure I did not impact the existing code for sMacro=”TRAC” or no sMacro specification, I modularized the HTML and XML related code.

    Option Explicit

    '---------------------------------------------------------------------------------------
    ' Procedure : JoinRange
    ' Author    : dick
    ' Date      : 3/31/2012
    ' Purpose   : Concatenate cell values with delimiters and line ends
    ' Args      : sMacro - preset delimeters, overrides other arguments
    '             sDelim - text inserted between cell values
    '             sLinestart - text inserted before the first cell value
    '             sLineEnd - text inserted after the last cell value
    '             sBlank - text used instead of nothing for blank cells
    '---------------------------------------------------------------------------------------
    '
    Private Function doHTMLHdr(ByVal sBlank As String, ByVal Hdr) As String
        doHTMLHdr = "<tr>"
        If TypeOf Hdr Is Range Then Hdr = Hdr.Value
        Dim J As Integer
        For J = LBound(Hdr, 2) To UBound(Hdr, 2)
            doHTMLHdr = doHTMLHdr & "<th>" _
                & IIf(Hdr(LBound(Hdr, 1), J) = "", sBlank, _
                    Hdr(LBound(Hdr, 1), J)) _
                & "</th>"
            Next J
        doHTMLHdr = doHTMLHdr & "</tr>" & vbNewLine
        End Function
    Private Function doHTML(rInput As Range, _
            Optional ByVal sBlank As String = "", _
            Optional ByVal Hdr) As String
        Dim sDelim As String, sLineStart As String, sLineEnd As String
       
        If Not IsMissing(Hdr) Then _
            doHTML = "<table>" & vbNewLine & doHTMLHdr(sBlank, Hdr)
        sLineStart = "<tr><td>"
        sDelim = "</td><td>"
        sLineEnd = "</td></tr>"

        Dim vaValues: vaValues = rInput.Value
        Dim I As Long, J As Long, sReturn As String
        For I = LBound(vaValues, 1) To UBound(vaValues, 1)
            sReturn = sLineStart
            For J = LBound(vaValues, 2) To UBound(vaValues, 2)
                If Len(vaValues(I, J)) = 0 Then
                   sReturn = sReturn & sBlank & sDelim
                Else
                    sReturn = sReturn & vaValues(I, J) & sDelim
                    End If
                Next J
            sReturn = Left$(sReturn, Len(sReturn) - Len(sDelim))
            sReturn = sReturn & sLineEnd & vbNewLine
            doHTML = doHTML & sReturn
            Next I
        If Not IsMissing(Hdr) Then doHTML = doHTML & "</table>"
        End Function
    Private Function doXML(rInput As Range, _
            ByVal EntityID As String, Optional ByVal Hdr) As String

        If TypeOf Hdr Is Range Then Hdr = Hdr.Value
       
        Dim vaValues: vaValues = rInput.Value
        Dim I As Long, J As Long, sReturn As String
        For I = LBound(vaValues, 1) To UBound(vaValues, 1)
            sReturn = "<" & EntityID & ">" & vbNewLine
            Dim HdrIdx As Integer: HdrIdx = LBound(Hdr, 2)
            For J = LBound(vaValues, 2) To UBound(vaValues, 2)
                sReturn = sReturn & vbTab & "<" & Hdr(LBound(Hdr), HdrIdx) & ">" _
                    & vaValues(I, J) _
                    & "</" & Hdr(LBound(Hdr), J) & ">" & vbNewLine
                HdrIdx = HdrIdx + 1
                Next J
            sReturn = sReturn & vbTab & "</" & EntityID & ">" & vbNewLine
            doXML = doXML & sReturn
            Next I
        End Function
    Private Sub copyToClipBoard(ByVal sWhat As String)
        Dim X As DataObject: Set X = New DataObject
        X.SetText sWhat
        X.PutInClipboard
        End Sub
    Public Function JoinRange(rInput As Range, _
            Optional ByVal sMacro As String = "", _
            Optional ByVal sDelim As String = "", _
            Optional ByVal sLineStart As String = "", _
            Optional ByVal sLineEnd As String = "", _
            Optional ByVal sBlank As String = "", _
            Optional ByVal EntityID As String, Optional ByVal Hdr) As String
        'EntityID is required when sMacro=XML _
         Hdr applies only when sMacro=XML or HTML
        Dim sReturn As String
        Dim vaValues As Variant
        Dim I As Long, J As Long
       
        Select Case UCase(sMacro)
        Case "HTMLTABLE", "HTML TABLE", "HTML":
            JoinRange = doHTML(rInput, sBlank, Hdr)
            GoTo XIT
        Case "XML":
            If IsMissing(EntityID) Then _
                JoinRange = "EntityID is required for XML output": GoTo ErrXIT
            If Not IsMissing(Hdr) Then
            ElseIf rInput.Rows.Count > 1 Then
                Set Hdr = rInput.Rows(1)
                Set rInput = rInput.Offset(1, 0).Resize(rInput.Rows.Count - 1)
            Else
                JoinRange = "Hdr is required for XML output": GoTo ErrXIT
                End If
            JoinRange = doXML(rInput, EntityID, Hdr)
            GoTo XIT
        Case "TRACTABLE", "TRAC", "TRAC TABLE"
            sDelim = "||"
            sLineStart = "||"
            sLineEnd = "||"
        Case Else:
            End Select
       
        vaValues = rInput.Value
        sReturn = sLineStart
       
        For I = LBound(vaValues, 1) To UBound(vaValues, 1)
            For J = LBound(vaValues, 2) To UBound(vaValues, 2)
                If Len(vaValues(I, J)) = 0 Then
                   sReturn = sReturn & sBlank & sDelim
                Else
                    sReturn = sReturn & vaValues(I, J) & sDelim
                End If
            Next J
        Next I
       
        sReturn = Left$(sReturn, Len(sReturn) - Len(sDelim))
       
        sReturn = sReturn & sLineEnd
       
        JoinRange = sReturn
    XIT:
        copyToClipBoard JoinRange
        Exit Function
    ErrXIT:
        End Function

Posting code or formulas in your comment? Use <code> tags!

  • <code lang="vb">Block of code goes here</code>
  • <code lang="vb" inline="true">Inline code goes here</code>
  • <code>Formula goes here</code>

Leave a Reply

Here's how to update your reports of company and nearly any web data: