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.