VBA Textjoin + Transpose

[Azza87]

Hello,

I am trying to textjoin + transpose a bunch of cells containing text from one worksheet to another. I could use the basic textjoin equation but I have over 200 sets of cells that I would need to apply the equation to, and it would be quite tedious to do it manually.

I thought that setting up a vba code with a command button should do the trick, especially since the sets of data will be constantly updated.

The way I set up the textjoin formula is in the following manner:

=TEXTJOIN(CHAR(10),TRUE,Sheet1!B6:B8)

That is because i want to have the cells displayed with a line space between each of them, as opposed to it being all in one line.

I am having some trouble writing up the code to include both the transpose and textjoin functions. I have attached an excel sheet to better display what I am trying to achieve.

Any help or tips would be highly appreciated.

A

 

[Chihiro]

With your sample... something like below.

Sub Demo()
Dim resAr
Dim cel As Range
Dim i As Long: i = 1
With Sheet1
    ReDim resAr(1 To (.Range("B4").CurrentRegion.Columns.Count / 3) + 1, 1 To 4)
    For Each cel In .Range("B4").CurrentRegion.Rows(1).Cells
        If Len(cel.Value) > 0 Then
            resAr(i + 1, 1) = cel.Value
            i = i + 1
        End If
    Next
    For i = 2 To 4
        Select Case i
            Case 2
                resAr(1, i) = "Task"
            Case 3
                resAr(1, i) = "Person"
            Case 4
                resAr(1, i) = "Date"
        End Select
    Next
    i = 1
    For Each cel In .Range("b4").CurrentRegion.Offset(2).Resize(.Range("B4").CurrentRegion.Rows.Count - 2).Columns
        resAr(Application.RoundUp((cel.Column - 1) / 3 + 1, 0), i + 1) = Join(Application.Transpose(cel.Value), vbCrLf)
        If i < 3 Then
            i = i + 1
        Else
            i = 1
        End If
    Next
   
End With
Sheet2.Range("B5").Resize(UBound(resAr), UBound(resAr, 2)) = resAr
End Sub