Convert Data Columns to Rows in Excel

[mminchev]

Hi I am trying to convert the following data from a column into a row

Example

People	Area
20	449
20	787
20	875
20	3555
20	3711
20	3760
20	4382
20	4558
20	4866
20	6344
20	6506
20	7218
21	621
21	723
21	2117
21	2229
21	4751
21	5029
21	5223
21	5421
21	5433
21	5752
21	5753
21	5773
21	6431
21	6532
21	6634

<tbody>
</tbody>

End Result to look like this:

20	21
449	621
787	723
875	2117
3555	2229
3711	4751
3760	5029
4382	5223
4558	5421
4866	5433
6344	5752
6506	5753
7218	5773
	6431
	6532
	6634

<tbody>
</tbody>

I have hundreds of these rows and columns and I cant think of a way to do it easy.

PLEASE HELP!

 

[mumps]

This macro assumes your data is in columns A and B of "Sheet1". The output will be placed in "Sheet2")

Sub ConvertData()
    Application.ScreenUpdating = False
    Dim rngUniques As Range, rng As Range
    Dim LastRow As Long
    Dim lColumn As Long
    lColumn = 1
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Sheets("Sheet1").Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("A1:A" & LastRow), Unique:=True
    Set rngUniques = Sheets("Sheet1").Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
    Sheets("Sheet1").Range("A1").AutoFilter
    For Each rng In rngUniques
        Sheets("Sheet1").Range("A1:B" & LastRow).AutoFilter Field:=1, Criteria1:=rng
        Sheets("Sheet2").Cells(1, lColumn) = rng
        Sheets("Sheet1").Range("B2:B" & LastRow).SpecialCells(xlCellTypeVisible).Copy Sheets("Sheet2").Cells(2, lColumn)
        lColumn = lColumn + 1
    Next rng
    Sheets("Sheet1").Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

 

[mminchev]

This macro assumes your data is in columns A and B of "Sheet1". The output will be placed in "Sheet2")

Sub ConvertData()
    Application.ScreenUpdating = False
    Dim rngUniques As Range, rng As Range
    Dim LastRow As Long
    Dim lColumn As Long
    lColumn = 1
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Sheets("Sheet1").Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("A1:A" & LastRow), Unique:=True
    Set rngUniques = Sheets("Sheet1").Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
    Sheets("Sheet1").Range("A1").AutoFilter
    For Each rng In rngUniques
        Sheets("Sheet1").Range("A1:B" & LastRow).AutoFilter Field:=1, Criteria1:=rng
        Sheets("Sheet2").Cells(1, lColumn) = rng
        Sheets("Sheet1").Range("B2:B" & LastRow).SpecialCells(xlCellTypeVisible).Copy Sheets("Sheet2").Cells(2, lColumn)
        lColumn = lColumn + 1
    Next rng
    Sheets("Sheet1").Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

Did a little change to It and it worked great! THANK YOU!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

 

[mumps]

You are very welcome.

 

[Rick Rothstein]

Here is another macro that you can consider. It assumes your data is in Columns A and B, but rather than output the results to a different sheet, it places the output on the same sheet starting in Column D.

[table="width: 500"]
[tr]
	[td]Sub ConvertData()
  Dim N As Long, Ar As Range
  Range("D1").CurrentRegion.ClearContents
  With Range("A2", Cells(Rows.Count, "A").End(xlUp))
    .Value = Evaluate(Replace("IF(@=" & .Offset(-1).Address & ",""=""&@,@)", "@", .Address))
  End With
  For Each Ar In Range("A2", Cells(Rows.Count, "B").End(xlUp).Offset(, -1)).SpecialCells(xlFormulas).Areas
    N = N + 1
    Range("C1").Offset(, N) = Ar(1).Offset(-1).Value
    Range("C1").Offset(1, N).Resize(Ar.Count + 1) = Ar.Offset(-1, 1).Resize(Ar.Count + 1).Value
  Next
  Columns("A").Replace "=", "", xlPart, , , , False, False
End Sub[/td]
[/tr]
[/table]