Macro to transpose multiple grouped colums to rows

rarlang

New Member
Joined
Feb 14, 2017
Messages
7
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
 
Ah, forgot to put in ""

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

@JLGWhiz and abbeyWigan: thank you both for your help!
 
Upvote 0
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:
Code:
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.
 
Upvote 0
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!
 
Last edited:
Upvote 0
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).
Code:
[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]
 
Last edited:
Upvote 0
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
ABCDEFGHIJK
1IDName 1Address 1Place 1Name 2Address 2Place 2Name 3Adress 3Place 3
2212AAZZ11BBYY22CCXX33
3354DDWW44EEVV55
4500FFUU66
5212GGTT77
6109HHSS88IIRR99
7358JJQQ10
8109KKPP11
9
Users



Excel 2007
ABCD
1
2
3
4
5
6
7
8
9
10
11
12
13
Output


And, after the macro:


Excel 2007
ABCD
1IDNameAddressPlace
2212AAZZ11
3212BBYY22
4212CCXX33
5354DDWW44
6354EEVV55
7500FFUU66
8212GGTT77
9109HHSS88
10109IIRR99
11358JJQQ10
12109KKPP11
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).

Code:
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.
 
Last edited:
Upvote 0
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).

Code:
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.
 
Upvote 0
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.
 
Upvote 0

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top