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]

Ah, forgot to put in ""

I used JLGWhiz' Code, and it works like a charm

@JLGWhiz and abbeyWigan: thank you both for your help!

 

[abbeyWigan]

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

Ruben, as JLGWhiz has advised, you need to change the "Dim... id%" which is an integer definition to a Variant by simply removing the "%", i.e. "Dim... id" (in your sample data, ID is always an integer but it appears that is not the case in your live data). The real problem is not that srcArr is a Variant but that its content cannot be coerced to an integer as expected.

Another point, I do like JGLWhiz' code for compactness but you will find it runs a lot slower because it's interacting with range objects all the time and you seem to have a large amount of data to process, nearly half a million cells not including iterations.

 

[JLGWhiz]

Ah, forgot to put in ""

I used JLGWhiz' Code, and it works like a charm

@JLGWhiz and abbeyWigan: thank you both for your help!

Happy to assist,
Regards, JLG

 

[rarlang]

Ruben, as JLGWhiz has advised, you need to change the "Dim... id%" which is an integer definition to a Variant by simply removing the "%", i.e. "Dim... id" (in your sample data, ID is always an integer but it appears that is not the case in your live data). The real problem is not that srcArr is a Variant but that its content cannot be coerced to an integer as expected.

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

Another point, I do like JGLWhiz' code for compactness but you will find it runs a lot slower because it's interacting with range objects all the time and you seem to have a large amount of data to process, nearly half a million cells not including iterations.

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!

 

[abbeyWigan]

AbbeyWigan

Ruben, Simply remove the "%"" after the "id%".

 

[Rick Rothstein]

Re: AbbeyWigan

Here is a macro that should do what you want about as quickly as is physically possible... run it with your data sheet active and the result you wanted will be written to Sheet2 (change the red highlighted text to the worksheet name you want output to go to if my guess of Sheet2 was wrong).

[table="width: 500"]
[tr]
	[td]Sub RedistributePerIDs()
  Dim R As Long, C As Long, X As Long, Z As Long, Arr As Variant, Data As Variant, Result As Variant
  Data = Range("A1").CurrentRegion
  ReDim Result(1 To UBound(Data, 1) * UBound(Data, 2), 1 To 4)
  For R = 2 To UBound(Data, 1)
    For C = 2 To UBound(Data, 2) Step 3
      If Len(Data(R, C)) Then
        X = X + 1
        Arr = Array(Data(R, 1), Data(R, C), Data(R, C + 1), Data(R, C + 2))
        For Z = 1 To 4
          Result(X, Z) = Arr(Z - 1)
        Next
      Else
        Exit For
      End If
    Next
  Next  Sheets("[B][COLOR="#FF0000"]Sheet2[/COLOR][/B]").Range("A1:D1") = Array("ID", "Name", "Address", "Place")
  Sheets("[B][COLOR="#FF0000"]Sheet2[/COLOR][/B]").Range("A2").Resize(UBound(Result), 4) = Result
End Sub[/td]
[/tr]
[/table]

 

[hiker95]

rarlang,

Here is another macro solution for you to consider, that will adjust to the number of raw data rows, and, columns, and, that uses two arrays in memory, and, should be very fast.

I assume that both worksheets, Users, and, Output, already exist.

Sample worksheets:

Excel 2007
	A	B	C	D	E	F	G	H	I	J	K
1	ID	Name 1	Address 1	Place 1	Name 2	Address 2	Place 2	Name 3	Adress 3	Place 3
2	212	AA	ZZ	11	BB	YY	22	CC	XX	33
3	354	DD	WW	44	EE	VV	55
4	500	FF	UU	66
5	212	GG	TT	77
6	109	HH	SS	88	II	RR	99
7	358	JJ	QQ	10
8	109	KK	PP	11
9
Users

Excel 2007
	A	B	C	D
1
2
3
4
5
6
7
8
9
10
11
12
13
Output

And, after the macro:

Excel 2007
	A	B	C	D
1	ID	Name	Address	Place
2	212	AA	ZZ	11
3	212	BB	YY	22
4	212	CC	XX	33
5	354	DD	WW	44
6	354	EE	VV	55
7	500	FF	UU	66
8	212	GG	TT	77
9	109	HH	SS	88
10	109	II	RR	99
11	358	JJ	QQ	10
12	109	KK	PP	11
13
Output

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Sub ReorgData()
' hiker95, 02/16/2017, ME991253
Dim wu As Worksheet, wo As Worksheet
Dim a As Variant, i As Long, c As Long
Dim o As Variant, j As Long
Dim lr As Long, lc As Long
Application.ScreenUpdating = False
Set wu = Sheets("Users")
Set wo = Sheets("Output")
With wu
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  lc = .Cells(1, Columns.Count).End(xlToLeft).Column
  a = .Range(.Cells(1, 1), .Cells(lr, lc))
  ReDim o(1 To UBound(a, 1) * (UBound(a, 2) - 1 / 3), 1 To 4)
End With
j = j + 1: o(j, 1) = "ID": o(j, 2) = "Name": o(j, 3) = "Address": o(j, 4) = "Place"
For i = 2 To UBound(a, 1) Step 1
  For c = 2 To UBound(a, 2) Step 3
    If Not a(i, c) = vbEmpty Then
      j = j + 1
      o(j, 1) = a(i, 1): o(j, 2) = a(i, c): o(j, 3) = a(i, c + 1): o(j, 4) = a(i, c + 2)
    End If
  Next c
Next i
With wo
  .UsedRange.ClearContents
  .Cells(1, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns(1).Resize(, UBound(o, 2)).AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

Then run the ReorgData macro.

 

[hiker95]

rarlang,

Here is another macro that should do what you want about as quickly as is physically possible.

With the same screenshots as my last reply:

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Sub ReorgData_V2()
' hiker95, 02/16/2017, ME991253
Dim a As Variant, i As Long, c As Long
Dim o As Variant, j As Long
a = Sheets("Users").Range("A1").CurrentRegion
ReDim o(1 To UBound(a, 1) * (UBound(a, 2) - 1 / 3), 1 To 4)
j = j + 1: o(j, 1) = "ID": o(j, 2) = "Name": o(j, 3) = "Address": o(j, 4) = "Place"
For i = 2 To UBound(a, 1) Step 1
  For c = 2 To UBound(a, 2) Step 3
    If Not a(i, c) = vbEmpty Then
      j = j + 1
      o(j, 1) = a(i, 1): o(j, 2) = a(i, c): o(j, 3) = a(i, c + 1): o(j, 4) = a(i, c + 2)
    End If
  Next c
Next i
With Sheets("Output")
  .UsedRange.ClearContents
  .Cells(1, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns(1).Resize(, UBound(o, 2)).AutoFit
  .Activate
End With
End Sub

Then run the ReorgData_V2 macro.

 

[abbeyWigan]

Re: AbbeyWigan

Ruben, Simply remove the "%"" after the "id%".

Hi Ruben, I see both Rick and Hiker have come up with equally good solutions for you. They both should work as fast as mine because they are array based rather than working on ranges - okay for a few cells but not for large data. I'm signed off for the week now and won't post until Monday. I will post my final solution then but I think you can make enough headway with the help from Rick and Hiker.

Have a nice weekend.

 

[hiker95]

Sorry, wrong thread.