Looking for the best way to transpose data from a single row into multiple rows

M

mminten

New Member
Joined
May 29, 2020
Messages
12
Office Version
  1. 2013
Platform
  1. Windows
I have done VBA stuff in the past but it has been a few years. I attempted to do this with a pivot table but couldn't get it to do it right. Lets start with the raw data:
Book1
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAKALAMANAOAPAQARASATAUAV
1#Date SubmittedEnter Group CodeHow many people do you want to register?my_emma_1Please select from the following: Guest 1: First NameGuest 1: Last NameGuest 1: Emailguest_1_addressguest_1_cityguest_1_stateguest_1_zipmy_emma_1Guest 2: First NameGuest 2: Last NameGuest 2: EmailAddress Same As Guest 1guest_2_addressguest_2_cityguest_2_stateguest_2_zipmy_emma_2Guest 3: First NameGuest 3: Last NameGuest 3: Emailguest_3_addressguest_3_cityguest_3_stateguest_3_zipmy_emma_3Guest 4: First NameGuest 4: Last NameGuest 4: Emailguest_4_addressguest_4_cityguest_4_stateguest_4_zipmy_emma_4Guest 5: First NameGuest 5: Last NameGuest 5: Emailguest_5_addressguest_5_cityguest_5_stateguest_5_zipmy_emma_5SECURITY QUESTION: What is 2 plus 2?
2641########3489042CheckednoJoeBlowemail@email.com123 Main StSpringfieldCA95843CheckedJaneBlowCheckedUncheckedUncheckedUncheckedUnchecked
3644########3480241CheckednoJohnSmithfake@email.com1 First StRENONV89521-4404UncheckedUncheckedselect-stateUncheckedUncheckedUncheckedUnchecked
4645########2147045CheckedyesJackLopezfakelopez@emai.com1 Virginia StreetRenoNV89501CheckedDiannaLopezfakelopez2@emai.comCheckedCheckedAnetteLopezfakelopez3@emai.com100 Second StRenoNV89501CheckedDeeLopezfakelopez4@emai.com100 Third StreetRenoNV89501CheckedBreanaLopezfakelopez5@emai.com100 Forth StreetRenoNV89501Checked
raw

Now we want to break out this data to look like this:
Book1
ABCDEFGHIJ
1Group NoBand NoFnameLnameEmailAddressCityStateZipJudging
23489042JoeBlowemail@email.com123 Main StSpringfieldCA95843no
3348904JaneBlowemail@email.com123 Main StSpringfieldCA95843no
43480241JohnSmithfake@email.com1 First StRENONV89521-4404no
52147045JackLopezfakelopez@emai.com1 Virginia StreetRenoNV89501yes
6214704DiannaLopezfakelopez2@emai.com1 Virginia StreetRenoNV89501yes
7214704AnetteLopezfakelopez3@emai.com100 Second StRenoNV89501yes
8214704DeeLopezfakelopez4@emai.com100 Third StreetRenoNV89501yes
9214704BreanaLopezfakelopez5@emai.com100 Forth StreetRenoNV89501yes
wanted

This is a key to which col goes where:
Book1
AB
1Enter Group CodeGroup No
2How many people do you want to register?Band No
3Guest 1: First NameFname
4Guest 1: Last NameLname
5Guest 1: EmailEmail
6guest_1_addressAddress
7guest_1_cityCity
8guest_1_stateState
9guest_1_zipZip
10Please select from the following: Judging
key


Basically what I need to do is look at the How many people do you want to register field and break it out into multiple rows adding each guest's information to the same Group No and Judging. If they don't have a physical address or email we want the data from the original entry to show (although that may be optional).
Is my best bet a Macro enabled spreadsheet and programming complicated VBA or is there a simpler way to do this?
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Sort by date Sort by votes
Try this:

VBA Code: 
Sub transpose_data()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long, k As Long, lr As Long, lr3 As Long, lc As Long, m As Long, n As Long
  Dim f As Range
  
  Set sh1 = Sheets("raw")     'fit names of sheets.
  Set sh2 = Sheets("wanted")
  Set sh3 = Sheets("key")
  
  lr = sh1.Range("D" & Rows.Count).End(3).Row
  lc = sh1.Cells(1, Columns.Count).End(1).Column
  a = sh1.Range("A1", sh1.Cells(lr, lc)).Value
  n = WorksheetFunction.Sum(sh1.Range("D:D"))
  lr3 = sh3.Range("A" & Rows.Count).End(3).Row
  ReDim b(1 To n, 1 To lr3)
  c = sh3.Range("A1", "C" & lr3).Value
  
  For i = 1 To UBound(c, 1)
    Set f = sh1.Rows(1).Find(c(i, 1), , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then c(i, 3) = f.Column
  Next
  
  For i = 2 To UBound(a, 1)
    For j = 1 To a(i, 4)
      k = k + 1
      For m = 1 To UBound(c, 1)
        b(k, m) = a(i, c(m, 3))
      Next
    Next
  Next
  
  sh2.Cells.ClearContents
  sh2.Range("A1").Resize(1, lr3).Value = Application.Transpose(sh3.Range("B1:B" & lr3).Value)
  sh2.Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
 
Upvote 0
DanteAmor said:
Try this:

VBA Code: 
Sub transpose_data()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long, k As Long, lr As Long, lr3 As Long, lc As Long, m As Long, n As Long
  Dim f As Range
 
  Set sh1 = Sheets("raw")     'fit names of sheets.
  Set sh2 = Sheets("wanted")
  Set sh3 = Sheets("key")
 
  lr = sh1.Range("D" & Rows.Count).End(3).Row
  lc = sh1.Cells(1, Columns.Count).End(1).Column
  a = sh1.Range("A1", sh1.Cells(lr, lc)).Value
  n = WorksheetFunction.Sum(sh1.Range("D:D"))
  lr3 = sh3.Range("A" & Rows.Count).End(3).Row
  ReDim b(1 To n, 1 To lr3)
  c = sh3.Range("A1", "C" & lr3).Value
 
  For i = 1 To UBound(c, 1)
    Set f = sh1.Rows(1).Find(c(i, 1), , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then c(i, 3) = f.Column
  Next
 
  For i = 2 To UBound(a, 1)
    For j = 1 To a(i, 4)
      k = k + 1
      For m = 1 To UBound(c, 1)
        b(k, m) = a(i, c(m, 3))
      Next
    Next
  Next
 
  sh2.Cells.ClearContents
  sh2.Range("A1").Resize(1, lr3).Value = Application.Transpose(sh3.Range("B1:B" & lr3).Value)
  sh2.Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
Click to expand...
Wow, thanks for writing that up! I am getting a "runtime error '9' subscript out of range" at the line with " b(k, m) = a(i, c(m, 3)) ". I am not really sure what that is supposed to do. My VBA is really rusty.
 
Upvote 0
Did you adjust to your sheet names on these lines?
Set sh1 = Sheets("raw")
Set sh2 = Sheets("wanted")
Set sh3 = Sheets("key")
 
Upvote 0
The error is due to the fact that one of the titles of the "key" sheet does not exist in the "raw" sheet. Review your data.

Try again, with this code:

VBA Code: 
Sub transpose_data()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long, k As Long, lr As Long, lr3 As Long, lc As Long, m As Long, n As Long
  Dim f As Range
 
  Set sh1 = Sheets("raw")     'fit names of sheets.
  Set sh2 = Sheets("wanted")
  Set sh3 = Sheets("key")
 
  lr = sh1.Range("D" & Rows.Count).End(3).Row
  lc = sh1.Cells(1, Columns.Count).End(1).Column
  a = sh1.Range("A1", sh1.Cells(lr, lc)).Value
  n = WorksheetFunction.Sum(sh1.Range("D:D"))
  lr3 = sh3.Range("A" & Rows.Count).End(3).Row
  ReDim b(1 To n, 1 To lr3)
  c = sh3.Range("A1", "C" & lr3).Value
 
  For i = 1 To UBound(c, 1)
    Set f = sh1.Rows(1).Find(c(i, 1), , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then
      c(i, 3) = f.Column
    Else
      MsgBox "This key:  -" & c(i, 1) & " - does not exist in the titles of the 'raw' sheet"
      Exit Sub
    End If
  Next
 
  For i = 2 To UBound(a, 1)
    For j = 1 To a(i, 4)
      k = k + 1
      For m = 1 To UBound(c, 1)
        b(k, m) = a(i, c(m, 3))
      Next
    Next
  Next
 
  sh2.Cells.ClearContents
  sh2.Range("A1").Resize(1, lr3).Value = Application.Transpose(sh3.Range("B1:B" & lr3).Value)
  sh2.Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
 
Upvote 0
DanteAmor said:
The error is due to the fact that one of the titles of the "key" sheet does not exist in the "raw" sheet. Review your data.

Try again, with this code:

VBA Code: 
Sub transpose_data()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long, k As Long, lr As Long, lr3 As Long, lc As Long, m As Long, n As Long
  Dim f As Range
 
  Set sh1 = Sheets("raw")     'fit names of sheets.
  Set sh2 = Sheets("wanted")
  Set sh3 = Sheets("key")
 
  lr = sh1.Range("D" & Rows.Count).End(3).Row
  lc = sh1.Cells(1, Columns.Count).End(1).Column
  a = sh1.Range("A1", sh1.Cells(lr, lc)).Value
  n = WorksheetFunction.Sum(sh1.Range("D:D"))
  lr3 = sh3.Range("A" & Rows.Count).End(3).Row
  ReDim b(1 To n, 1 To lr3)
  c = sh3.Range("A1", "C" & lr3).Value
 
  For i = 1 To UBound(c, 1)
    Set f = sh1.Rows(1).Find(c(i, 1), , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then
      c(i, 3) = f.Column
    Else
      MsgBox "This key:  -" & c(i, 1) & " - does not exist in the titles of the 'raw' sheet"
      Exit Sub
    End If
  Next
 
  For i = 2 To UBound(a, 1)
    For j = 1 To a(i, 4)
      k = k + 1
      For m = 1 To UBound(c, 1)
        b(k, m) = a(i, c(m, 3))
      Next
    Next
  Next
 
  sh2.Cells.ClearContents
  sh2.Range("A1").Resize(1, lr3).Value = Application.Transpose(sh3.Range("B1:B" & lr3).Value)
  sh2.Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
Click to expand...
I thought I had checked that but now that I double checked it works! Thank you! Thank you!!

One other possible adjustment... Is there a way to have the number in Col B of the "wanted" sheet to only print that number for the first instance of each row in the "raw" tab? That way the second, third, fourth instances would be blank and they can visually see a break for each Group No?
 
Upvote 0
mminten said:
I thought I had checked that but now that I double checked it works! Thank you! Thank you!!

One other possible adjustment... Is there a way to have the number in Col B of the "wanted" sheet to only print that number for the first instance of each row in the "raw" tab? That way the second, third, fourth instances would be blank and they can visually see a break for each Group No?
Click to expand...
After taking a deeper look this only takes the data from the first "Guest 1" and not the others. Current there is a possibility of 5 guests and we may expand to 10.
If you apply the code you sent to my raw data you get the first two rows of the wanted tab with Joe Blow and his info, we need it to show Joe Blow in the first row and Jane Blow (with her possible data) in the second row. The same goes for the Lopez family in row 4 of the raw data. They need 5 rows with each family member's different name, email, and address in a row below the first one. Here is how it should work in plain English:

If "raw" - Col D is 1 just add Col C, F, G-M from "raw" into their corresponding columns in "wanted".
If "raw" - Col D is 2 add the data from above in the first available row and then add Col C,F,O,P,Q,S,T,U,V in "raw" (notice we have to skip Col R here) into their corresponding columns in "wanted" in the next row.
If "raw" - Col D is 3 add the data from above in the first available rows and then add Col C,F,X-AD in "raw" into their corresponding columns in "wanted" in the next row.
If "raw" - Col D is 4 add the data from above in the first available rows and then add Col C,F,AF-AL in "raw" into their corresponding columns in "wanted" in the next row.
If "raw" - Col D is 5 add the data from above in the first available rows and then add Col C,F,AN-AT in "raw" into their corresponding columns in "wanted" in the next row.
Continue this pattern for a possible 10 guests (current data set only has 5 but we may expand to 10).
Ignore Col AV in "raw", we will most likely remove that or it will be at the end.
 
Upvote 0
I have already reviewed your example well and already understood the result.
mminten said:
Continue this pattern for a possible 10 guests (current data set only has 5 but we may expand to 10).
Click to expand...
Put the data on the "key" sheet, identifying with # the titles that are repeated n times.
Dante Amor
AB
1Enter Group CodeGroup No
2How many people do you want to register?Band No
3Guest #: First NameFname
4Guest #: Last NameLname
5Guest #: EmailEmail
6guest_#_addressAddress
7guest_#_cityCity
8guest_#_stateState
9guest_#_zipZip
10Please select from the following: Judging
key

Note: You can add other titles from cell A11 down.

Try this code:
VBA Code: 
Sub transpose_data()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long, k As Long, lr As Long, lr3 As Long, lc As Long
  Dim m As Long, n As Long, totc As Long, tc As Long
  Dim f As Range
  Dim tit As String
 
  Set sh1 = Sheets("raw")     'fit names of sheets.
  Set sh2 = Sheets("wanted")
  Set sh3 = Sheets("key")
 
  lr = sh1.Range("D" & Rows.Count).End(3).Row
  lc = sh1.Cells(1, Columns.Count).End(1).Column
  a = sh1.Range("A1", sh1.Cells(lr, lc)).Value
  n = WorksheetFunction.Sum(sh1.Range("D:D"))
  totc = WorksheetFunction.CountIf(sh1.Range("1:1"), "*First Name*")
 
  lr3 = sh3.Range("A" & Rows.Count).End(3).Row
  ReDim b(1 To n, 1 To lr3)
  c = sh3.Range("A1", sh3.Cells(lr3, totc + 2)).Value
 
  For tc = 1 To totc      'total columns
    For i = 1 To UBound(c, 1)
      tit = Replace(c(i, 1), "#", tc)
      Set f = sh1.Rows(1).Find(tit, , xlValues, xlWhole, , , False)
      If Not f Is Nothing Then
        c(i, tc + 2) = f.Column
      Else
        MsgBox "This key: " & tit & " does not exist in the titles of the 'raw' sheet"
        Exit Sub
      End If
    Next
  Next
 
  For i = 2 To UBound(a, 1)   'rows raw data
    For j = 1 To a(i, 4)      'times
      k = k + 1
      For m = 1 To UBound(c, 1) 'titles in key
        b(k, m) = a(i, c(m, j + 2))
        If j > 1 Then b(k, 2) = ""
      Next
    Next
  Next
 
  sh2.Cells.ClearContents
  sh2.Range("A1").Resize(1, lr3).Value = Application.Transpose(sh3.Range("B1:B" & lr3).Value)
  sh2.Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
 
Last edited:
Upvote 0
Solution
DanteAmor said:
I have already reviewed your example well and already understood the result.

Put the data on the "key" sheet, identifying with # the titles that are repeated n times.
Dante Amor
AB
1Enter Group CodeGroup No
2How many people do you want to register?Band No
3Guest #: First NameFname
4Guest #: Last NameLname
5Guest #: EmailEmail
6guest_#_addressAddress
7guest_#_cityCity
8guest_#_stateState
9guest_#_zipZip
10Please select from the following: Judging
key

Note: You can add other titles from cell A11 down.

Try this code:
VBA Code: 
Sub transpose_data()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long, k As Long, lr As Long, lr3 As Long, lc As Long
  Dim m As Long, n As Long, totc As Long, tc As Long
  Dim f As Range
  Dim tit As String
 
  Set sh1 = Sheets("raw")     'fit names of sheets.
  Set sh2 = Sheets("wanted")
  Set sh3 = Sheets("key")
 
  lr = sh1.Range("D" & Rows.Count).End(3).Row
  lc = sh1.Cells(1, Columns.Count).End(1).Column
  a = sh1.Range("A1", sh1.Cells(lr, lc)).Value
  n = WorksheetFunction.Sum(sh1.Range("D:D"))
  totc = WorksheetFunction.CountIf(sh1.Range("1:1"), "*First Name*")
 
  lr3 = sh3.Range("A" & Rows.Count).End(3).Row
  ReDim b(1 To n, 1 To lr3)
  c = sh3.Range("A1", sh3.Cells(lr3, totc + 2)).Value
 
  For tc = 1 To totc      'total columns
    For i = 1 To UBound(c, 1)
      tit = Replace(c(i, 1), "#", tc)
      Set f = sh1.Rows(1).Find(tit, , xlValues, xlWhole, , , False)
      If Not f Is Nothing Then
        c(i, tc + 2) = f.Column
      Else
        MsgBox "This key: " & tit & " does not exist in the titles of the 'raw' sheet"
        Exit Sub
      End If
    Next
  Next
 
  For i = 2 To UBound(a, 1)   'rows raw data
    For j = 1 To a(i, 4)      'times
      k = k + 1
      For m = 1 To UBound(c, 1) 'titles in key
        b(k, m) = a(i, c(m, j + 2))
        If j > 1 Then b(k, 2) = ""
      Next
    Next
  Next
 
  sh2.Cells.ClearContents
  sh2.Range("A1").Resize(1, lr3).Value = Application.Transpose(sh3.Range("B1:B" & lr3).Value)
  sh2.Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
Click to expand...
Ok, once again, wow and thank you.

I think I am adding to the key wrong. Starting at key - A11 I added in Guest 2: First Name - guest_2_zip and in corresponding column headers in Col B (I did this all the way to guest 5 for each field). Check out screenshot1.png. Now it is just adding extra columns on the end of the same row. In row 1 instead of having Cols A-J with the column headers I need I have Cols A - AL with repeated column headers after J. Also, the same names appear repeated for each row of the original data. Look at the Lopez family in the attached screenshot2.png. It shows Jack Lopez repeated in rows 5-9 Cols C-I, then the rest of the family is showing in the extra columns to the right (repeated).

Did I adjust the key incorrectly?
 

Attachments

  • screenshot1.png
    screenshot1.png
    63.1 KB · Views: 8
  • screenshot2.png
    screenshot2.png
    59.4 KB · Views: 6
Upvote 0
mminten said:
Starting at key - A11 I added in Guest 2: First Name
Click to expand...
No. I didn't explain myself well. Just copy my example from the post #8 and that's it.
The macro is designed to identify the carcacter "#" and replace it with the number 1, 2, 3, etc. That is already done by the macro in automatic, you do not have to put that number.



DanteAmor said:
Note: You can add other titles from cell A11 down.
Click to expand...
I mean you can add another column, for example the "Date Submitted" column, and the macro, automatically adds it to the result.
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Solved
Excel 2016 VBA - Pull data from multiple sheets to One with specificities
Replies
3
Views
250
mumps
mumps
A
  • Solved
take amount from last row in listbox on form and put into next column
Replies
7
Views
118
Abdo
A
Q
  • Question Question
Macro needed to insert 4 rows in table, copy data from above, copy data from another sheet and paste special (transpose values) to those new rows...re
Replies
1
Views
228
sijpie
sijpie
dezibluenose
  • Solved
Countifs formula not picking up dates, when reference columns show as dates?!
Replies
7
Views
404
Alex Blakenburg
A
M
  • Question Question
VBA Subtotal 47,000+ Rows
Replies
1
Views
202
igold
igold

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

Share this page

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