The Daily Dose

Public Function JoinText(target As Range, _
                           Optional Delimiter As String = ",", _
                           Optional FieldDelimiter As String = ",", _
                           Optional DelimitEnd As Variant = False, _
                           Optional SkipBlanks As Boolean = False, _
                           Optional Transpose As Boolean = False) As String

‘Based on code from Nigel Heffernan at Excellerando.Blogspot.com
‘http://excellerando.blogspot.co.nz/2012/08/join-and-split-functions-for-2.html

‘ Join up a 2-dimensional array into a string.
‘  Test with something like ? JoinText2([A2:C8]," ",".",0,1,"!")

‘   ####################
‘   # Revision history #
‘   ####################

‘   Date (YYYYMMDD)     Revised by:         Changes:
‘   20141114            Jeff Weir           Turned into worksheet function, added FinalDelimiter and Transpose options

Dim InputArray As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim lngNext As Long
Dim i_lBound As Long
Dim i_uBound As Long
Dim j_lBound As Long
Dim j_uBound As Long
Dim arrTemp1() As String
Dim arrTemp2() As String

    If target.Rows.Count = 1 Then
        If target.Columns.Count = 1 Then
            GoTo errhandler ‘Target is a single cell
        Else
            ‘ Selection is a Row Vector
            InputArray = Application.Transpose(target)
            Transpose = True
        End If
    Else
        If target.Columns.Count = 1 Then
            ‘ Selection is a Column Vecton
            InputArray = target
        Else:
            ‘Selection is 2D range. Transpose it if that’s what the user has asked for
            If Transpose Then
                InputArray = Application.Transpose(target)
                Transpose = True
            Else: InputArray = target
            End If
        End If
    End If

    i_lBound = LBound(InputArray, 1)
    i_uBound = UBound(InputArray, 1)
    j_lBound = LBound(InputArray, 2)
    j_uBound = UBound(InputArray, 2)
   
    ReDim arrTemp1(j_lBound To j_uBound)
    ReDim arrTemp2(i_lBound To i_uBound)

    lngNext = 1
    For i = j_lBound To j_uBound
        On Error Resume Next
        If SkipBlanks Then
            If Transpose Then
                ReDim arrTemp2(i_lBound To WorksheetFunction.CountA(target.Rows(i)))
            Else
                ReDim arrTemp2(i_lBound To WorksheetFunction.CountA(target.Columns(i)))
            End If
        End If
        If Err.Number = 0 Then
            k = 1
            For j = i_lBound To i_uBound
                If SkipBlanks Then
                    If InputArray(j, i) <> "" Then
                        arrTemp2(k) = InputArray(j, i)
                        k = k + 1
                    End If
                Else
                    arrTemp2(j) = InputArray(j, i)
                End If
            Next j
            arrTemp1(lngNext) = Join(arrTemp2, Delimiter)
            lngNext = lngNext + 1
        Else:
            Err.Clear
        End If
    Next i
     
    If SkipBlanks Then ReDim Preserve arrTemp1(1 To lngNext – 1)
    If lngNext > 2 Then
        JoinText = Join(arrTemp1, FieldDelimiter)
    Else: JoinText = arrTemp1(1)
    End If
    If DelimitEnd And JoinText <> "" Then JoinText = JoinText & FieldDelimiter

errhandler:
End Function