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 = " "
sLineStart = "

"
sLineEnd = "

"
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 thoughts on “JoinRange Update

  1. 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. 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 = "

    "
    If TypeOf Hdr Is Range Then Hdr = Hdr.Value
    Dim J As Integer
    For J = LBound(Hdr, 2) To UBound(Hdr, 2)
    doHTMLHdr = doHTMLHdr & "

    " _
    & IIf(Hdr(LBound(Hdr, 1), J) = "", sBlank, _
    Hdr(LBound(Hdr, 1), J)) _
    & "

    "
    Next J
    doHTMLHdr = doHTMLHdr & "

    " & 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 = "

    " & vbNewLine & doHTMLHdr(sBlank, Hdr)
    sLineStart = "

    "

    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 & "

    "
    sDelim = "
    "
    sLineEnd = "

    "
    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) _
    & "" & vbNewLine
    HdrIdx = HdrIdx + 1
    Next J
    sReturn = sReturn & vbTab & "" & 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? Use <pre> tags for VBA and <code> tags for inline.

Leave a Reply

Your email address will not be published.