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:

ID	Name 1	Address 1	Place 1	Name 2	Address 2	Place 2	Name 3	Adress 3	Place 3
212	AA	ZZ	11	BB	YY	22	CC	XX	33
354	DD	WW	44	EE	VV	55
500	FF	UU	66
212	GG	TT	77
109	HH	SS	88	II	RR	99
358	JJ	QQ	10
109	KK	PP	11

<tbody>
</tbody>

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:

ID	Name	Address	Place
212	AA	ZZ	11
212	BB	YY	22
212	CC	XX	33
354	DD	WW	44
354	EE	VV	55
500	FF	UU	66
212	GG	TT	77
109	HH	SS	88
109	II	RR	99
358	JJ	QQ	10
109	KK	PP	11

<tbody>
</tbody>

Any suggestions to get to the above result?

Thanks,

Ruben

 

[abbeyWigan]

Reuben, I can look at solving this for you but first a couple of questions:

1. Are the headers part of your data or just for information?
2. Can it be assumed that the first empty space in a row marks the end of that row and there will be no more data after that?

 

[rarlang]

Reuben, I can look at solving this for you but first a couple of questions:

1. Are the headers part of your data or just for information?
2. Can it be assumed that the first empty space in a row marks the end of that row and there will be no more data after that?

Hi Abbey,

To answer your questions:
1. The headers are just for information, so not part of the data
2. Yes, the first empty space in a row marks the end of that row.

Thanks,

Ruben

 

[abbeyWigan]

Leave that with me Ruben, I'll put something together when I've got a few minutes unless someone else beats me to it.

Regards.

 

[abbeyWigan]

Hi Ruben,

A quick solution for you below. I have done it as a function so that you can pass your data to it and receive it back re-arranged.

There is a test code below to try it out with. Sorry not a lot of comments but I trust you can get by without.

All the best.

Function ReArrange(ArrayIn)
'   By AbbeyWigan (15/02/2017)
'   Returns an array formatted as required by Ruben (rarlang)
'   ArrayIn can be an array or a range object.
    Dim i&, j&, id%, rCnt%, cCnt%, typ$
    Dim srcArr, tgtArr
    
    typ = TypeName(ArrayIn)
    Select Case typ
        Case "Variant()": srcArr = ArrayIn
        Case "Range": srcArr = ArrayIn.Value
        Case Else: Exit Function
    End Select
    ReDim tgtArr(1 To 4, 1 To 999) 'Make the last dimension as large as
    cCnt = 1                       'needed to accommodate expected data.
    For i = 1 To UBound(srcArr, 1)
        id = srcArr(i, 1)
        For j = 2 To UBound(srcArr, 2)
            rCnt = rCnt + 1
            If rCnt = 1 And srcArr(i, j) = "" Then
                rCnt = 0: Exit For
            ElseIf rCnt = 1 Then
                tgtArr(1, cCnt) = id: rCnt = 2
            End If
            tgtArr(rCnt, cCnt) = srcArr(i, j)
            If rCnt = 4 Then
                rCnt = 0: cCnt = cCnt + 1
            End If
        Next j
    Next i
    If cCnt > 0 Then
        ReDim Preserve tgtArr(1 To 4, 1 To cCnt - 1)
        ReArrange = Application.Transpose(tgtArr)
    Else
        ReArrange = Array()
    End If
End Function

Sub test_RA()
    Dim rng As Range
    Dim arrIn, arrOut
    
    'This assumes data is on sheet named "Data" in the given range. Amend to suit.
    Set rng = ThisWorkbook.Worksheets("Data").Range("A2:J8")
    arrIn = rng.Value
    
'    arrOut = ReArrange(rng) 'Call function.
    arrOut = ReArrange(arrIn) 'Call function.
    'Write re-arranged data back to sheet starting at given address. Amend to suit.
    Set rng = ThisWorkbook.Worksheets("Data").Range("F12")
    Set rng = rng.Resize(UBound(arrOut, 1), UBound(arrOut, 2))
    rng.Value = arrOut
End Sub

 

[JLGWhiz]

try this

Sub rearrange()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range, i As Long, xps As Variant
Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name
    With sh1
        For Each c In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
            For i = 2 To .Cells(c.Row, Columns.Count).End(xlToLeft).Column Step 3
                .Cells(c.Row, i).Resize(1, 3).Copy sh2.Cells(Rows.Count, 2).End(xlUp)(2)
                sh2.Cells(Rows.Count, 2).End(xlUp).Offset(, -1) = c.Value
            Next
        Next
    End With
    Application.CutCopyMode = False
End Sub

 

[rarlang]

Hi Abbey,

Thanks. I amended your suggested test Code to:

Sub test_RA()
Dim rng As Range
Dim arrIn, arrOut
    
Set rng = ThisWorkbook.Worksheets("Users").Range("A1:DE4000")
arrIn = rng.Value
    
' arrOut = ReArrange(rng) 'Call function.
arrOut = ReArrange(arrIn) 'Call function.

Set rng = ThisWorkbook.Worksheets("Output").Range("A1")
Set rng = rng.Resize(UBound(arrOut, 1), UBound(arrOut, 2))
rng.Value = arrOut
End Sub

However, when running the test Code, Excel mentions a run-type '13' error: type mismatch.
Debug highlights the following Function line.

        id = srcArr(i, 1)

Any idea what's wrong?

 

[JLGWhiz]

Hi Abbey,

Thanks. I amended your suggested test Code to:

Sub test_RA()
Dim rng As Range
Dim arrIn, arrOut
    
Set rng = ThisWorkbook.Worksheets("Users").Range("A1:DE4000")
arrIn = rng.Value
    
' arrOut = ReArrange(rng) 'Call function.
arrOut = ReArrange(arrIn) 'Call function.

Set rng = ThisWorkbook.Worksheets("Output").Range("A1")
Set rng = rng.Resize(UBound(arrOut, 1), UBound(arrOut, 2))
rng.Value = arrOut
End Sub

However, when running the test Code, Excel mentions a run-type '13' error: type mismatch.
Debug highlights the following Function line.

        id = srcArr(i, 1)

Any idea what's wrong?

id is declared as Integer and srcArr is variant. Did you try the code in post #6?

 

[rarlang]

Hi JLGWhiz,

Thanks for your Code.
I'm trying to apply it, and have two sheets: "Users" as input sheet, "Output" as output sheet.
In that regard, how should I amend:

Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name

Also, not sure what is meant by

id is declared as Integer and srcArr is variant.

Thanks,

Ruben

 

[jolivanes]

Set sh1 = Sheets("Users") 'Where the data is
Set sh2 = Sheets("Output") 'Where the reformatted data goes into