Convert Rows to Columns

[BruceHawk]

I thought someone would have asked this, and they may have, but I was not successful in finding the answer in Excel.

I have a large spreadsheet in rows that I would like to copy and convert to columns.

Example of what I have:

[TABLE="width: 256"]
<colgroup><col width="64" span="4" style="width:48pt"> </colgroup><tbody>[TR]
[TD="width: 64"]Location[/TD]
[TD="width: 64"]Data 1[/TD]
[TD="width: 64"]Data 2[/TD]
[TD="width: 64"]Data 3[/TD]
[/TR]
[TR]
[TD]Origin 1[/TD]
[TD]Option 1[/TD]
[TD]Alt 2[/TD]
[TD]Other 1[/TD]
[/TR]
[TR]
[TD]Origin 2[/TD]
[TD]Option 1[/TD]
[TD]Alt 2[/TD]
[TD]Other 1[/TD]
[/TR]
[TR]
[TD]Origin 3[/TD]
[TD]Option 2[/TD]
[TD]Alt 4[/TD]
[TD]Other 1[/TD]
[/TR]
[TR]
[TD]Origin 4[/TD]
[TD]Option 3[/TD]
[TD]Alt 4[/TD]
[TD]Other 1[/TD]
[/TR]
[TR]
[TD]Origin 5[/TD]
[TD]Option 3[/TD]
[TD]Alt 5[/TD]
[TD]Other 2[/TD]
[/TR]
</tbody>[/TABLE]

What I would like to convert it to:

[TABLE="width: 128"]
<colgroup><col width="64" span="2" style="width:48pt"> </colgroup><tbody>[TR]
[TD="width: 64"]Location[/TD]
[TD="width: 64"]Data[/TD]
[/TR]
[TR]
[TD]Origin 1[/TD]
[TD]Option 1[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Alt 2[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Other 1[/TD]
[/TR]
[TR]
[TD]Origin 2[/TD]
[TD]Option 1[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Alt 2[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Other 1[/TD]
[/TR]
[TR]
[TD]Origin 3[/TD]
[TD]Option 2[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Alt 4[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Other 1[/TD]
[/TR]
[TR]
[TD]Origin 4[/TD]
[TD]Option 3[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Alt 4[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Other 1[/TD]
[/TR]
[TR]
[TD]Origin 5[/TD]
[TD]Option 3[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Alt 5[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Other 2[/TD]
[/TR]
</tbody>[/TABLE]

Help! Thanks!!

 

[hiker95]

BruceHawk,

Here is another macro solution for you to consider, that is based on your latest flat text display in your reply #9, that uses two arrays in memory, and, will adjust to the number of raw data rows, and, columns, in the active worksheet.

The results will be written in the active worksheet, beginning, in the third column to the right of the last used raw data column.

With your raw data in range A1:D6, the results will be written to range G1:H14.

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 ReorganizeData_V2()
' hiker95, 08/26/2017, ME1017714
Application.ScreenUpdating = False
Dim a As Variant, i As Long, c As Long, lr As Long, lc As Long, n As Long
Dim o As Variant, j As Long
With ActiveSheet
  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 = (lr - 1) * (lc - 1)
  ReDim o(1 To n + 1, 1 To 2)
  j = j + 1: o(j, 1) = "Location": o(j, 2) = "Data"
  For i = 2 To UBound(a, 1)
    For c = 2 To UBound(a, 2)
      If Not a(i, c) = vbEmpty Then
        j = j + 1: o(j, 1) = a(i, 1): o(j, 2) = a(i, c)
      End If
    Next c
  Next i
  .Cells(1, lc + 3).Resize(UBound(o, 1), UBound(o, 2)) = o
  lr = .Cells(Rows.Count, lc + 3).End(xlUp).Row
  For i = 2 To lr
    n = Application.CountIf(.Columns(lc + 3), .Cells(i, lc + 3).Value)
    If n > 1 Then
      .Cells(i + 1, lc + 3).Resize(n - 1).ClearContents
      i = i + n - 1
    End If
  Next i
  .Columns(lc + 3).Resize(, 2).AutoFit
End With
Application.ScreenUpdating = True
End Sub

 

[hiker95]

BruceHawk,

Here is another macro solution for you to consider, that is based on your latest flat text display in your reply #9, that uses two arrays in memory, and, will adjust to the number of raw data rows, and, columns, in the active worksheet.

The results will be written in the active worksheet, beginning, in the third column to the right of the last used raw data column.

With your raw data in range A1:D6, the results will be written to range G1:H16, and, will also display the blank cells.


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 ReorganizeData_WithBlanks()
' hiker95, 08/27/2017, ME1017714
Application.ScreenUpdating = False
Dim a As Variant, i As Long, c As Long, lr As Long, lc As Long, n As Long
Dim o As Variant, j As Long
With ActiveSheet
  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 = (lr - 1) * (lc - 1)
  ReDim o(1 To n + 1, 1 To 2)
  j = j + 1: o(j, 1) = "Location": o(j, 2) = "Data"
  For i = 2 To UBound(a, 1)
    For c = 2 To UBound(a, 2)
      If c = 2 Then
        j = j + 1: o(j, 1) = a(i, 1): o(j, 2) = a(i, c)
      Else
        j = j + 1: o(j, 2) = a(i, c)
      End If
    Next c
  Next i
  .Cells(1, lc + 3).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns(lc + 3).Resize(, 2).AutoFit
End With
Application.ScreenUpdating = True
End Sub