Changing Columns Into Rows with Column Headings

[Alex20850]

I want to change columns into rows.
I was not able to get in contact with original programmer. This is not for a business, but strictly for my own learning.

The before data looks like this.
| A | B | C | D |
+-------+------------+------------+------------+
1 | Name | Language 1 | Language 2 | Language 3 |
+=======+============+============+============+
2 | John | English | Chinese | Spanish |
3 | Wendy | Chinese | French | English |
4 | Peter | Spanish | Chinese | English |
The VBA below creates this on a new sheet:
| A | B |
+-------+----------+
1 | Name | Language |
+=======+==========+
2 | John | English |
3 | John | Chinese |
4 | John | Spanish |
5 | Wendy | Chinese |
6 | Wendy | French |
7 | Wendy | English |
8 | Peter | Spanish |
9 | Peter | Chinese |
10 | Peter | English |
I would like it to do this instead.
| A | B | C |
+----------+-----------+----------+
1 | Column 1 | Column 2 | Column 3 |
+==========+===========+==========|
2 | John | Language 1| English |
3 | John | Language 2| Chinese |
4 | John | Language 3| Spanish |
5 | Wendy | Language 1| Chinese |
6 | Wendy | Language 2| French |
7 | Wendy | Language 3| English |
8 | Peter | Language 1| Spanish |
9 | Peter | Language 2| Chinese |
10 | Peter | Language 3| English |

 
Sub ShrinkTable()
Dim maxRows As Double
Dim maxCols As Integer
Dim data As Variant
maxRows = Cells(1, 1).End(xlDown).row
maxCols = Cells(1, 1).End(xlToRight).Column
data = Range(Cells(1, 1), Cells(maxRows, maxCols))
Dim newSht As Worksheet
Set newSht = Sheets.Add
With newSht
.Cells(1, 1).Value = "Name"
.Cells(1, 2).Value = "Column"
Dim writeRow As Double
writeRow = 2
Dim row As Double
row = 2
Dim col As Integer
Do While True
col = 2
Do While True
If data(row, col) = "" Then Exit Do 'Skip Blanks
'Name
.Cells(writeRow, 1).Value = data(row, 1)
'Language
.Cells(writeRow, 2).Value = data(row, col)
writeRow = writeRow + 1
If col = maxCols Then Exit Do 'Exit clause
col = col + 1
Loop
If row = maxRows Then Exit Do 'exit cluase
row = row + 1
Loop
End With
End Sub

 

[Tom Urtis]

If your worksheet is set up as you depicted it, this is one way to accomplish what you want. Change the reference to Sheet1 in the code's strSourceSheet variable if your original list is on a worksheet whose tab name is other than Sheet1.

Sub Test1()
Dim strSourceSheet$, strListSheet$
Dim lngRow&, LastRow&, NextRow&
Dim LastColumnSource&, xColumn&

strSourceSheet = "Sheet1"
strListSheet = "zzzList"
NextRow = 2

With Sheets(strSourceSheet).Range("A1").CurrentRegion
LastRow = .Rows.Count
LastColumnSource = .Columns.Count
End With

With Application
.ScreenUpdating = False
.DisplayAlerts = False

On Error Resume Next
Sheets("zzzList").Delete
Err.Clear
Sheets.Add(after:=Sheets(Sheets.Count)).Name = strListSheet
.DisplayAlerts = True

With Sheets(strSourceSheet)
For lngRow = 2 To LastRow
For xColumn = 2 To LastColumnSource
Cells(NextRow, 1).Value = .Cells(lngRow, 1).Value
If IsEmpty(Sheets(strSourceSheet).Cells(lngRow, xColumn)) = False Then
Cells(NextRow, 2).Value = .Cells(1, xColumn).Value
Cells(NextRow, 3).Value = .Cells(lngRow, xColumn).Value
End If
NextRow = NextRow + 1
Next xColumn
Next lngRow
End With

For xColumn = 1 To Range("B1").CurrentRegion.Columns.Count
Cells(1, xColumn).Value = "Column " & xColumn
Next xColumn
Range("A1").CurrentRegion.Columns.AutoFit

.ScreenUpdating = True
End With
End Sub

 

[hiker95]

Alex20850,

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

You can change the raw data worksheet name in the macro.

The results will be written to a new worksheet, worksheet Results. I can change this worksheet name in the macro, if you want.

Sample raw data:

Excel 2007
	A	B	C	D	E
1	Name	Language 1	Language 2	Language 3
2	John	English	Chinese	Spanish
3	Wendy	Chinese	French	English
4	Peter	Spanish	Chinese	English
5
6
Sheet1

And, after the macro in a new worksheet Results:

Excel 2007
	A	B	C
1	Name	Language #	Language
2	John	Language 1	English
3	John	Language 2	Chinese
4	John	Language 3	Spanish
5	Wendy	Language 1	Chinese
6	Wendy	Language 2	French
7	Wendy	Language 3	English
8	Peter	Language 1	Spanish
9	Peter	Language 2	Chinese
10	Peter	Language 3	English
11
Results

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, 03/29/2016, ME931108
Dim w1 As Worksheet, wr As Worksheet
Dim lr As Long, lc As Long
Dim a As Variant, i As Long, c As Long
Dim o As Variant, j As Long, n As Long
Application.ScreenUpdating = False
Set w1 = Sheets("Sheet1")   '<-- you can change the sheet name here
With w1
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  lc = .Cells(1, Columns.Count).End(xlToLeft).Column
  a = .Range(.Cells(1, 1), .Cells(lr, lc))
  n = (UBound(a, 1) - 1) * (UBound(a, 2) - 1) + 1
  ReDim o(1 To n, 1 To 3)
End With
j = j + 1: o(j, 1) = "Name": o(j, 2) = "Language #": o(j, 3) = "Language"
For i = 2 To UBound(a, 1)
  For c = 2 To UBound(a, 2)
    j = j + 1: o(j, 1) = a(i, 1): o(j, 2) = a(1, c): o(j, 3) = a(i, c)
  Next c
Next i
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wr = Sheets("Results")
wr.UsedRange.Clear
With wr
  .Cells(1).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns(1).Resize(, UBound(o, 2)).AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ReorgData macro.

 

[Alex20850]

Thanks lots. That works great and I can compare it to the original and see the chnages you made for my learning.
This forum is a great, GREAT resource.

 

[Alex20850]

Looks great. Looking forward to going into it in detail.
As I told Tom, this is such a great resource for learning.
Thanks!

 

[hiker95]

Looks great. Looking forward to going into it in detail.
As I told Tom, this is such a great resource for learning.
Thanks!

Alex20850,

Thanks for the feedback.

You are very welcome. Glad we could help.

And, come back anytime.