VBA to Concatenate Multi-Value Cells

[apo]

Here's my stab at it..

Private Sub CommandButton1_Click()
    Dim x, zz, i As Long, ii As Long, iii As Long
    x = Application.Transpose([A2].CurrentRegion)
    ReDim zz(1 To UBound(x, 2))
    For i = LBound(x, 2) To UBound(x, 2)
        Z = Replace(Join(Application.Transpose(Application.Index(x, 0, 1)), vbLf), vbLf, ";")
        For ii = 0 To 1
            For iii = ii To 7 Step 2
                If zz(i) = "" Then
                    zz(i) = zz(i) & Split(Z, ";")(iii)
                Else: zz(i) = zz(i) & "\" & Split(Z, ";")(iii)
                End If
            Next iii
            If iii > 7 And ii = 0 Then zz(i) = zz(i) & ";"
        Next ii
        zz(i) = Replace(zz(i), ";\", ";")
    Next i
    [E2].Resize(UBound(zz), 1).Value = zz
End Sub