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

mminten · Mar 18, 2022

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

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

U

V

W

X

Y

Z

AA

AB

AC

AD

AE

AF

AG

AH

AI

AJ

AK

AL

AM

AN

AO

AP

AQ

AR

AS

AT

AU

AV

1

#

Date Submitted

Enter Group Code

How many people do you want to register?

my_emma_1

Please select from the following:

Guest 1: First Name

Guest 1: Last Name

Guest 1: Email

guest_1_address

guest_1_city

guest_1_state

guest_1_zip

my_emma_1

Guest 2: First Name

Guest 2: Last Name

Guest 2: Email

Address Same As Guest 1

guest_2_address

guest_2_city

guest_2_state

guest_2_zip

my_emma_2

Guest 3: First Name

Guest 3: Last Name

Guest 3: Email

guest_3_address

guest_3_city

guest_3_state

guest_3_zip

my_emma_3

Guest 4: First Name

Guest 4: Last Name

Guest 4: Email

guest_4_address

guest_4_city

guest_4_state

guest_4_zip

my_emma_4

Guest 5: First Name

Guest 5: Last Name

Guest 5: Email

guest_5_address

guest_5_city

guest_5_state

guest_5_zip

my_emma_5

SECURITY QUESTION: What is 2 plus 2?

2

641

########

348904

2

Checked

no

Joe

Blow

email@email.com

123 Main St

Springfield

CA

95843

Checked

Jane

Blow

Checked

Unchecked

3

644

########

348024

1

Checked

no

John

Smith

fake@email.com

1 First St

RENO

NV

89521-4404

Unchecked

select-state

Unchecked

4

645

########

214704

5

Checked

yes

Jack

Lopez

fakelopez@emai.com

1 Virginia Street

Reno

NV

89501

Checked

Dianna

Lopez

fakelopez2@emai.com

Checked

Anette

Lopez

fakelopez3@emai.com

100 Second St

Reno

NV

89501

Checked

Dee

Lopez

fakelopez4@emai.com

100 Third Street

Reno

NV

89501

Checked

Breana

Lopez

fakelopez5@emai.com

100 Forth Street

Reno

NV

89501

Checked

raw

Now we want to break out this data to look like this:

Book1

A

B

C

D

E

F

G

H

I

J

1

Group No

Band No

Fname

Lname

Email

Address

City

State

Zip

Judging

2

348904

2

Joe

Blow

email@email.com

123 Main St

Springfield

CA

95843

no

3

348904

Jane

Blow

email@email.com

123 Main St

Springfield

CA

95843

no

4

348024

1

John

Smith

fake@email.com

1 First St

RENO

NV

89521-4404

no

5

214704

5

Jack

Lopez

fakelopez@emai.com

1 Virginia Street

Reno

NV

89501

yes

6

214704

Dianna

Lopez

fakelopez2@emai.com

1 Virginia Street

Reno

NV

89501

yes

7

214704

Anette

Lopez

fakelopez3@emai.com

100 Second St

Reno

NV

89501

yes

8

214704

Dee

Lopez

fakelopez4@emai.com

100 Third Street

Reno

NV

89501

yes

9

214704

Breana

Lopez

fakelopez5@emai.com

100 Forth Street

Reno

NV

89501

yes

wanted

This is a key to which col goes where:

Book1

A

B

1

Enter Group Code

Group No

2

How many people do you want to register?

Band No

3

Guest 1: First Name

Fname

4

Guest 1: Last Name

Lname

5

Guest 1: Email

Email

6

guest_1_address

Address

7

guest_1_city

City

8

guest_1_state

State

9

guest_1_zip

Zip

10

Please 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?

DanteAmor · Mar 19, 2022

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

mminten · Mar 19, 2022

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

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.

KRice · Mar 19, 2022

Did you adjust to your sheet names on these lines?
Set sh1 = Sheets("raw")
Set sh2 = Sheets("wanted")
Set sh3 = Sheets("key")

DanteAmor · Mar 19, 2022

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

mminten · Mar 19, 2022

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

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?

mminten · Mar 19, 2022

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?

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.

DanteAmor · Mar 19, 2022

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).

Put the data on the "key" sheet, identifying with # the titles that are repeated n times.

Dante Amor

A

B

1

Enter Group Code

Group No

2

How many people do you want to register?

Band No

3

Guest #: First Name

Fname

4

Guest #: Last Name

Lname

5

Guest #: Email

Email

6

guest_#_address

Address

7

guest_#_city

City

8

guest_#_state

State

9

guest_#_zip

Zip

10

Please 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

mminten · Mar 20, 2022

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

A

B

1

Enter Group Code

Group No

2

How many people do you want to register?

Band No

3

Guest #: First Name

Fname

4

Guest #: Last Name

Lname

5

Guest #: Email

Email

6

guest_#_address

Address

7

guest_#_city

City

8

guest_#_state

State

9

guest_#_zip

Zip

10

Please 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

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?

DanteAmor · Mar 20, 2022

mminten said:
Starting at key - A11 I added in Guest 2: First Name

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.

I mean you can add another column, for example the "Date Submitted" column, and the macro, automatically adds it to the result.

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

mminten

New Member

Excel Facts

DanteAmor

Well-known Member

mminten

New Member

KRice

Well-known Member

DanteAmor

Well-known Member

mminten

New Member

mminten

New Member

DanteAmor

Well-known Member

mminten

New Member

Attachments

DanteAmor

Well-known Member

Similar threads

Forum statistics

Share this page

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

New Member

Excel Facts

Well-known Member

New Member

Well-known Member

Well-known Member

New Member

New Member

Well-known Member

New Member

Attachments

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock