Macro to transpose multiple grouped colums to rows

[rarlang]

I've been searching this forum to see if I could find a suitable solution, but haven't found a proper one yet, so here we go.

My table looks like this:
[TABLE="width: 700"]
<tbody>[TR]
[TD]ID[/TD]
[TD]Name 1[/TD]
[TD]Address 1[/TD]
[TD]Place 1[/TD]
[TD]Name 2[/TD]
[TD]Address 2[/TD]
[TD]Place 2[/TD]
[TD]Name 3[/TD]
[TD]Adress 3[/TD]
[TD]Place 3[/TD]
[/TR]
[TR]
[TD]212[/TD]
[TD]AA[/TD]
[TD]ZZ[/TD]
[TD]11[/TD]
[TD]BB[/TD]
[TD]YY[/TD]
[TD]22[/TD]
[TD]CC[/TD]
[TD]XX[/TD]
[TD]33[/TD]
[/TR]
[TR]
[TD]354[/TD]
[TD]DD[/TD]
[TD]WW[/TD]
[TD]44[/TD]
[TD]EE[/TD]
[TD]VV[/TD]
[TD]55[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]500[/TD]
[TD]FF[/TD]
[TD]UU[/TD]
[TD]66[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]212[/TD]
[TD]GG[/TD]
[TD]TT[/TD]
[TD]77[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]109[/TD]
[TD]HH[/TD]
[TD]SS[/TD]
[TD]88[/TD]
[TD]II[/TD]
[TD]RR[/TD]
[TD]99[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]358[/TD]
[TD]JJ[/TD]
[TD]QQ[/TD]
[TD]10[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]109[/TD]
[TD]KK[/TD]
[TD]PP[/TD]
[TD]11[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Note that there are about 90 possible columns that might be used by a certain row (so, up to column "Place 30"). Also note that there is no logic in Name, Address, or Place cell values (in contrast to the above example).

I'd like to use a macro that transposes each three following columns (Name, Address, Place) to a separate row as follows:

[TABLE="width: 500"]
<tbody>[TR]
[TD]ID[/TD]
[TD]Name[/TD]
[TD]Address[/TD]
[TD]Place[/TD]
[/TR]
[TR]
[TD]212[/TD]
[TD]AA[/TD]
[TD]ZZ[/TD]
[TD]11[/TD]
[/TR]
[TR]
[TD]212[/TD]
[TD]BB[/TD]
[TD]YY[/TD]
[TD]22[/TD]
[/TR]
[TR]
[TD]212[/TD]
[TD]CC[/TD]
[TD]XX[/TD]
[TD]33[/TD]
[/TR]
[TR]
[TD]354[/TD]
[TD]DD[/TD]
[TD]WW[/TD]
[TD]44[/TD]
[/TR]
[TR]
[TD]354[/TD]
[TD]EE[/TD]
[TD]VV[/TD]
[TD]55[/TD]
[/TR]
[TR]
[TD]500[/TD]
[TD]FF[/TD]
[TD]UU[/TD]
[TD]66[/TD]
[/TR]
[TR]
[TD]212[/TD]
[TD]GG[/TD]
[TD]TT[/TD]
[TD]77[/TD]
[/TR]
[TR]
[TD]109[/TD]
[TD]HH[/TD]
[TD]SS[/TD]
[TD]88[/TD]
[/TR]
[TR]
[TD]109[/TD]
[TD]II[/TD]
[TD]RR[/TD]
[TD]99[/TD]
[/TR]
[TR]
[TD]358[/TD]
[TD]JJ[/TD]
[TD]QQ[/TD]
[TD]10[/TD]
[/TR]
[TR]
[TD]109[/TD]
[TD]KK[/TD]
[TD]PP[/TD]
[TD]11[/TD]
[/TR]
</tbody>[/TABLE]

Any suggestions to get to the above result?

Thanks,

Ruben

 

[rarlang]

@Rick and hiker95,

Thank you for your solutions.
I'll try both to see what the results look like.

Cheers

 

[hiker95]

rarlang,

You are very welcome. Glad we could help.

Will be watching for the results of your testing.

 

[abbeyWigan]

Thanks, although I still don't fully understand. Can you explain it in layman terms?



I agree, the code is compact, but Excel stops responding and it did take quite some time to get the results.

Happy to try your solution as well, once I understand the integer vs Variant issue.
Thanks!

Ruben,

As promised, I post here my final solution which, hopefully, should work straight out of the box for you. I would recommend this function-based approach given your current level of proficiency because you can be confident that any changes you make to your main code (in this case "test_RA") will not affect the function.

All the best.

Sub test_RA()
'Amend this sub to suit your needs leaving the function alone.
    Dim rng As Range
    Dim arrIn, arrOut
    
    Set rng = ThisWorkbook.Worksheets("Users").Range("A1:DE4000")
    arrOut = ReArrange(rng, False) 'Pass data to function to rearrange. Change "False" to "True" if the _
    first row of Data is header row.
    If UBound(arrOut, 1) = -1 Then
        MsgBox "No data found!", vbExclamation + vbOKOnly, "Re-Arrange"
    Else
        Set rng = ThisWorkbook.Worksheets("Output").Range("A1") 'Define location for rearranged data,
        Set rng = rng.Resize(UBound(arrOut, 1), UBound(arrOut, 2)) 'resize and
        rng.Value = arrOut 'write it.
    End If
End Sub

Function ReArrange(Data, Optional FirstRowIsHeader As Boolean = False)
'   By AbbeyWigan (15/02/2017)
'   16/02/2017: Revised to handle variable data blocks.
'   20/02/2017: Option added to let function know if first row is header row.
'               Otherwise, it is assumed there is no header row.
'   Returns an array formatted as required by Ruben (rarlang)
'   Data can be an array or a range object.
    Dim i&, j&, k%, cnt%, stRow%, typ$, id, srcArr, tgtArr
    Const blk% = 3
    
    typ = TypeName(Data)
    Select Case typ
        Case "Variant()": srcArr = Data
        Case "Range": srcArr = Data.Value
        Case Else: Exit Function
    End Select
    If FirstRowIsHeader Then
        stRow = 2
    Else
        stRow = 1
    End If
    ReDim tgtArr(1 To 4, 1 To UBound(srcArr, 1))
    For i = stRow To UBound(srcArr, 1)
        id = srcArr(i, 1)
        For j = 2 To UBound(srcArr, 2) Step blk
            If srcArr(i, j) = "" Then
                Exit For
            Else
                 cnt = cnt + 1: tgtArr(1, cnt) = id
                For k = 2 To 4
                    tgtArr(k, cnt) = srcArr(i, j + k - 2)
                Next k
            End If
        Next j
    Next i
    If cnt > 0 Then
        ReDim Preserve tgtArr(1 To 4, 1 To cnt)
        ReArrange = Application.Transpose(tgtArr)
    Else
        ReArrange = Array()
    End If
End Function