How to convert table from one form to other form?

[SarahDetroja]

Hello Fellow Experts,

Please see attached image. I have a table in the form of "Source" format. I want to convert that table in the form of "Output" format. What is the best way to do that?

Many thanks in advance for your kind help.

Regards
Sarah.

 

[SarahDetroja]

Here is the link to the sample file in Google Drive.

 

[Peter_SSs]

Try this with a copy of your workbook. I have assumed that your actual data starts in row 2 with headers in row 1.

Sub Rearrange()
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long
  
  a = Range("A2", Range("D" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a) / 3, 1 To 5)
  For i = 1 To UBound(a) Step 3
    k = k + 1
    b(k, 1) = a(i, 1): b(k, 2) = a(i, 2): b(k, 3) = a(i, 4): b(k, 4) = a(i + 1, 4): b(k, 5) = a(i + 2, 4)
  Next i
  With Range("F2:J2").Resize(k)
    .Value = b
    .Rows(0).Value = Array("First Name", "Last Name", "Color", "Country", "City")
    .EntireColumn.AutoFit
  End With
End Sub

 

[SarahDetroja]

Try this with a copy of your workbook. I have assumed that your actual data starts in row 2 with headers in row 1.

Sub Rearrange()
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long
 
  a = Range("A2", Range("D" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a) / 3, 1 To 5)
  For i = 1 To UBound(a) Step 3
    k = k + 1
    b(k, 1) = a(i, 1): b(k, 2) = a(i, 2): b(k, 3) = a(i, 4): b(k, 4) = a(i + 1, 4): b(k, 5) = a(i + 2, 4)
  Next i
  With Range("F2:J2").Resize(k)
    .Value = b
    .Rows(0).Value = Array("First Name", "Last Name", "Color", "Country", "City")
    .EntireColumn.AutoFit
  End With
End Sub

Hi Peter,

This fantastic! That's exactly what I wanted and works like a charm.

I really appreciate it.

Thanks again.

Regards
Sarah

 

[Peter_SSs]

You're welcome. Thanks for the follow-up.

 

[SarahDetroja]

You're welcome. Thanks for the follow-up.

You are most welcome.

I may have an additional request in the same above problem which I will request if I can't solve it in the next 30 minutes or so.

Thank you.

 

[SarahDetroja]

Hi Peter,

A couple of changes which if I have coding expertise can be easily accommodated but unfortunately, I don't have.

1) Now instead of 3 questions, there are 10 questions.
2) Like "First Name" and "Last Name" there are additional two columns that would be fixed for each record. "Age" and "Join Date"

Please see attached image and link to Drive spreadsheet Sample File

Can you please provide a solution once again?

Many thanks again in advance for your kind help.

Note: If possible please tell me, in future if I have more questions and more columns (like Name, Age) what do I need to do?

 

[Peter_SSs]

in future if I have more questions and more columns (like Name, Age) what do I need to do?

Pretty hard to give you a fixed rule as to what to do since even your fixed columns are not all at the left side etc, but see if this helps. You will have to fixe the headers section of the results yourself.

Sub Rearrange_v2()
  Dim a As Variant, b As Variant, FCols As Variant
  Dim i As Long, j As Long, k As Long
 
  Const NumQns As Long = 10
  Const FixedCols As String = "1 2 5 6"   'Columns A, B, E F
  Const AnswerCol As Long = 4             'Column D
  Const NumCols As Long = 6               'Total number of columns
 
 
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, NumCols).Value
  FCols = Split(FixedCols)
  ReDim b(1 To UBound(a) / NumQns, 0 To UBound(Split(FixedCols)) + NumQns)
  For i = 1 To UBound(a) Step NumQns
    k = k + 1
    For j = 0 To UBound(FCols)
      b(k, j) = a(i, FCols(j))
    Next j
    For j = UBound(FCols) + 1 To UBound(FCols) + NumQns
      b(k, j) = a(i + j - UBound(FCols) - 1, AnswerCol)
    Next j
  Next i
  With Range("Z2").Resize(k, NumQns + UBound(FCols) + 1)
    .Value = b
'    .Rows(0).Value = Array("First Name", "Last Name", .....) 'Add other headers here
    .EntireColumn.AutoFit
  End With
End Sub

 

[SarahDetroja]

Hi Peter,

Again master class from you! Again worked like a charm!

Many thanks. It's super helpful. You made my day (&week!)

Regards
Sarah

 

[Peter_SSs]

Glad it helped.