Text Functions‎ > ‎

Rows To Columns

 Sample File for macros on this page:   RowsToColumns-ParseMacros.xls
 
 
PART 1a - Data already in separate columns
 
 
Sometimes data is provided in a single-row format with multiple answers that represent similar data all in that row, and it is necessary to reorganize that data into a more "database"-like format with a separate row for each answers while keeping the original key column(s) the same.  Like so:
 
 
            Example 1a
 
  A B C D
1 Person Child1 Child2 Child3
2 Bob billy james rob
3 Cindy jen    
4 Dan grace doug britanny
5 Fred tom zack  
6 Greta gina tina  
...into
 
        Example 1a
 
  A B C D
1 Person Child1    
2 Bob billy    
3 Bob james    
4 Bob rob    
5 Cindy jen    
6 Dan grace    
7 Dan doug    
8 Dan britanny    
9 Fred tom    
10 Fred zack    
11 Greta gina    
12 Greta tina    
Or perhaps:
                    Example 1a2
 
  A B C D E F G H I J
1 Server Group Name Group ID User ID User ID User ID User ID User ID User ID User ID
2 Server 1 super 1 jeff dave ted        
3 Server 1 duper 2 sting bowie          
4 Server 1 admins 3 bob dave jeff simon stuart colin phil
5 Server 1 operator 4 bob dave jeff simon      
6 Server 2 admins 3 bob dave jeff simon      
7 Server 2 operator 4 jamie theo gordy batman ted simon  
8 Server 2 dba 5 cheetah leopard jaguar        
 
...into
                    Example 1a2
 
  A B C D
1 Server Group Name Group ID User ID
2 Server 1 super 1 jeff
3 Server 1 super 1 dave
4 Server 1 super 1 ted
5 Server 1 duper 2 sting
6 Server 1 duper 2 bowie
7 Server 1 admins 3 bob
8 Server 1 admins 3 dave
9 Server 1 admins 3 jeff
10 Server 1 admins 3 simon
11 Server 1 admins 3 stuart
12 Server 1 admins 3 colin
13 Server 1 admins 3 phil
14 Server 1 operator 4 bob
15 Server 1 operator 4 dave
16 Server 1 operator 4 jeff
17 Server 1 operator 4 simon
18 Server 2 admins 3 bob
19 Server 2 admins 3 dave
20 Server 2 admins 3 jeff
21 Server 2 admins 3 simon
22 Server 2 operator 4 jamie
23 Server 2 operator 4 theo
24 Server 2 operator 4 gordy
25 Server 2 operator 4 batman
26 Server 2 operator 4 ted
27 Server 2 operator 4 simon
28 Server 2 dba 5 cheetah
29 Server 2 dba 5 leopard
30 Server 2 dba 5 jaguar
 
 
This macro will reorganize the data into column format. It will prompt you to select the column to start the split down from and also ask if the data has a title row in row1.
 

CODE

Sub ReOrganize()
'Author:    Jerry Beaucaire
'Date:      9/15/2010
'Summary:   Reorganize a multivalue column database
'           into a single value per row database
'           First column(s) are duplicated
Dim LR  As Long     'last row of data, we start at the bottom
Dim Col As Long     'column to start reorganization
Dim Rw  As Long
Dim Num As Long     'number of values on each row to split down
Dim Titles As Boolean

'Use a popup to select the column to start split down
    On Error Resume Next
    Col = Application.InputBox("Select a column to begin the split down." & vbLf _
        & "All columns to the left will be duplicated.", "Select column", "$B:$B", Type:=8).Column
    If Col = 0 Then Exit Sub

'Inquire if data has titles in row1
    Titles = MsgBox("Does your data have titles? (if yes, they must be in row1)", vbYesNo)

Application.ScreenUpdating = False  'speed up execution
LR = Range("A" & Rows.Count).End(xlUp).Row  'last row with data

'From the bottom up, split data down
    For Rw = LR To (1 - Titles) Step -1
        Num = Cells(Rw, Columns.Count).End(xlToLeft).Column
        If Num > Col Then
            Cells(Rw + 1, "A").Resize(Num - Col).EntireRow.Insert xlShiftDown
            With Range(Cells(Rw, Col + 1), Cells(Rw, Num))
                .Copy
                Cells(Rw + 1, Col).PasteSpecial xlPasteAll, Transpose:=True
                .Clear
            End With
        End If
        If Rw = 1 Then Exit For
    Next Rw

'remove extra titles
    If Titles Then Range(Cells(1, Col + 1), Cells(1, Columns.Count)).Clear
   
'Duplicate values in beginning column(s)
    LR = Cells(Rows.Count, Col).End(xlUp).Row
    With Range("A1", Cells(LR, Col - 1))
        .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
        .Value = .Value
    End With

Application.ScreenUpdating = True
End Sub

  
 
PART 1b - Data in separate columns in groups
 
For data where the columns to be merged down are in groups of two or more, this version allows that:
                          Example 1b1
       A B C D E F G H I J K
1 Person Address Date Child1 Email1 Date Child2 Email2 Date Child3 Email3
2 Bob Addr1 7/1/2000 billy ttt 7/10/2000 james eee 7/14/2000 rob ddd
3 Cindy Addr2 7/2/2000 jen ttt            
4 Dan Addr3 7/3/2000 grace eee 7/11/2000 doug ggg 7/15/2000 britanny sss
5 Fred Addr4 7/4/2000 tom www       7/12/2000 zack ddd
6 Greta Addr5 7/5/2000 gina qqq       7/13/2000 tina eee

...into
                     
Example 1b2 
  A B C D E
1 Person Address Date Child1  Email
2 Bob Addr1 7/1/2000 billy  ttt
3 Bob Addr1 7/10/2000 james  eee
4 Bob Addr1 7/14/2000 rob  ddd
5 Cindy Addr2 7/2/2000 jen  ttt
6 Dan Addr3 7/3/2000 grace  eee
7 Dan Addr3 7/11/2000 doug  ggg
8 Dan Addr3 7/15/2000 britanny  sss
9 Fred Addr4 7/4/2000 tom  www
10 Fred Addr4 7/12/2000 zack  ddd
11 Greta Addr5 7/5/2000 gina  qqq
12 Greta Addr5 7/13/2000 tina  eee
 

            Or....                                        Example 1c1 
  A B D E F G I
1 Person Address Class1 Date Class2 Date Class3 Date
2 Bob Addr1 Complete 7/1/2000 Not Started   Started 7/3/2000
3 Cindy Addr2 Complete 7/2/2000 Not Started   Not Started  
4 Dan Addr3 Started 7/3/2000 Started 7/3/2000 Complete 7/1/2000
                          ...into                       Example 1c2
A B C D E
1 Person Address Description Status Date
2 Bob Addr1 Class1 Complete 7/1/2000
3 Bob Addr1 Class2 Not Started  
4 Bob Addr1 Class3 Started 7//3/2000
5 Cindy Addr2 Class1 Complete 7/2/2000
6 Cindy Addr2 Class2 Not Started  
7 Cindy Addr2 Class3 Not Started  
8 Dan Addr3 Class1 Started 7/3/2000
9 Dan Addr3 Class2 Started 7/3/2000
10 Dan Addr3 Class3 Complete 7/1/2000

CODE

Option Explicit

Sub ReOrganize2()
'JBeaucaire  (rewritten 3/21/2014)
'Turns row data into columnar data, groups of data merged down together
'Option to copy the header down as a new data cell from each group created
Dim wsRAW As Worksheet, wsNEW As Worksheet, ClassNm As Boolean
Dim NR As Long, LR As Long, Rw As Long, FirstCol As Long, ColGrps As Long, LastCol As Long, Col As Long

'Confirm raw data is the activesheet onscreen
If MsgBox("Reorganize the activesheet?", vbYesNo, "Proceed?") = vbNo Then Exit Sub

'User indicates which column is the first column to parse down, columns to left will be duplicated
FirstCol = Application.InputBox("What is the first column number to parse out?" _
    & vbLf & "(B=2, C=3, etc.)" & vbLf & "Columns to the left will all be duplicated.", "First Column Number", 4, Type:=1)
If FirstCol < 2 Then Exit Sub

'User indicates how many columns to parse down in groups
ColGrps = Application.InputBox("How many columns per group to parse out?", "Columns Per Group", 2, Type:=1)
If ColGrps = 0 Then Exit Sub

'Option to put the title from the first column of each group into each new data row as data
If MsgBox("Copy the first column name title for each group down into each new row?", vbYesNo) = vbYes Then ClassNm = True

Set wsRAW = ActiveSheet
Set wsNEW = Sheets.Add

'Create titles on new sheet
If ClassNm = True Then
    wsNEW.Range("A1").Resize(, FirstCol - 1).Value = wsRAW.Range("A1").Resize(, FirstCol - 1).Value
    wsNEW.Cells(1, FirstCol).Resize(, 2).Value = [{"Class Name","Status"}]
    wsNEW.Cells(1, FirstCol + 2).Resize(, ColGrps - 1).Value = wsRAW.Cells(1, FirstCol + 1).Resize(, ColGrps - 1).Value
Else
    wsNEW.Range("A1").Resize(, FirstCol + ColGrps - 1).Value = wsRAW.Range("A1").Resize(, FirstCol + ColGrps - 1).Value
End If

'Figure out how many rows and columns of data need to be processed
LR = wsRAW.Range("A" & Rows.Count).End(xlUp).Row
LastCol = wsRAW.Cells(1, Columns.Count).End(xlToLeft).Column

'Set the first row to enter new data on new sheet
NR = 2

'process one raw data row at a time
For Rw = 2 To LR
'process each group of column
    For Col = FirstCol To LastCol Step ColGrps
      If wsRAW.Cells(Rw, Col) <> "" Then
'first copy the initial columns that will exist on all the parsed out rows
        wsNEW.Range("A" & NR).Resize(, FirstCol - 1).Value = wsRAW.Range("A" & Rw).Resize(, FirstCol - 1).Value
'if the first column name is being copied down, do that, then copy the remaining cells of the group down
        If ClassNm = True Then
            wsNEW.Cells(NR, FirstCol).Value = wsRAW.Cells(1, Col).Value
            wsNEW.Cells(NR, FirstCol + 1).Resize(, ColGrps).Value = wsRAW.Cells(Rw, Col).Resize(, ColGrps).Value
'if first column name is not being copied down, copy down all the cells of the group
        Else
            wsNEW.Cells(NR, FirstCol).Resize(, ColGrps).Value = wsRAW.Cells(Rw, Col).Resize(, ColGrps).Value
        End If
'set the next empty row to copy into
        NR = NR + 1
      End If
    Next Col
Next Rw
'cleanup result
wsNEW.Columns.AutoFit
wsRAW.Range("A2").Resize(, FirstCol + ColGrps - 1).Copy
wsNEW.Range("A1").Resize(NR, FirstCol + ColGrps - 1).PasteSpecial xlPasteFormats
wsNEW.Range("A2").Select
ActiveWindow.FreezePanes = True
End Sub
 
 
 
 
 
PART 2 - Data in a delimited string
Sometimes data is provided in a single-row format with multiple answers that represent similar data all in that row, but the answers come in a comma delimited format, or colons or line feeds. For example:
 
                Example 1
 
 
A B
1 Ron NY,SF
2 Dennis Australia
3 Rohit Delhi
Mumbai
4 Bob LA: MO: DD
 
And you need each delimited value in its own column to create a searchable database:
 
    Example 2
 
 
A B
1 Ron NY
2 Ron SF
3 Dennis Australia
4 Rohit Delhi
5 Rohit Mumbai
6 Bob LA
7 Bob MO
8 Bob DD
This macro will reformat the data if it is delimited by colons, commas, Alt-Enter (character 10), or just spaces inside a cell as shown in Example 1. If none of the delimiters exist the row will be skipped.  You can add/delete sections as shown to reduce the number of delimiters evaluated.
 

CODE

Sub ParseByColumn()
'Jerry Beaucaire  (4/23/2010)
'Split delimited column data into separate rows
'duplicate previous column values as needed
Dim LR As Long, Rw As Long, Col As Long, MyVal As Long
Dim MyArr As Variant, LC As Long
Dim Titles As Long
Application.ScreenUpdating = False

Titles = 8 - MsgBox("Does the data have titles in row1?", vbYesNo, "Include row1?")

'set column to evaluate:  1="A", 2="B", 3="C", etc...
    Col = 3

LR = Range("A" & Rows.Count).End(xlUp).Row

For Rw = LR To Titles Step -1
  'separated by commas
    If InStr(Cells(Rw, Col), ",") > 0 Then
        MyArr = Split(Cells(Rw, Col), ",")
  'separated by Alt-Enter
    ElseIf InStr(Cells(Rw, Col), Chr(10)) > 0 Then
        MyArr = Split(Cells(Rw, Col), Chr(10))
  'separated by semicolons
    ElseIf InStr(Cells(Rw, Col), ";") > 0 Then
        MyArr = Split(Cells(Rw, Col), ";")
  'separated by colons
    ElseIf InStr(Cells(Rw, Col), ":") > 0 Then
        MyArr = Split(Cells(Rw, Col), ":")
  'separated by spaces
    ElseIf InStr(Cells(Rw, Col), " ") > 0 Then
        MyArr = Split(Application.WorksheetFunction.Trim(Cells(Rw, Col)), " ")
    End If
       
    Rows(Rw).Copy
    Rows(Rw + 1 & ":" & Rw + UBound(MyArr)).Insert xlShiftDown
    Cells(Rw, Col).Resize(UBound(MyArr) + 1).Value = _
        Application.WorksheetFunction.Transpose(MyArr)
Next Rw

'Cleanup appearance
    Cells.Columns.AutoFit
    Cells.Rows.AutoFit
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

Sub ParseByColumns2()
'Jerry Beaucaire   5/5/2010
'For data with no titles
Dim LastCol As Long
Dim CpyCol  As Long
Dim CpyRNG  As Range

LastCol = Cells.Find("*", Cells(Rows.Count, Columns.Count), _
    SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

    For CpyCol = 3 To LastCol
        Set CpyRNG = Columns(CpyCol).SpecialCells(xlCellTypeConstants)
        Set CpyRNG = Union(CpyRNG, CpyRNG.Offset(0, -CpyCol + 1))
        CpyRNG.Copy Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        Set CpyRNG = Nothing
    Next CpyCol

'Optional
Range("C1", Cells(Rows.Count, LastCol)).ClearContents
Columns("A:B").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlNo, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
End Sub

 
PART 3 - Data in a table into row format
 
 
Data in a table format with multiple categories that represent similar data all in that row, but the answers come in a comma delimited format. For example:
 
 
                             Example 1
 
  A B C D
1 Code Data1 Data2 Data3
2 ZZAA12 5% 7% 9%
3 ZZAA13 3%    
4 ZZAA14 7% 6% 4%
5 ZZAA15 2% 3%  
6 ZZAA16 6% 4%  
7 ZZAA17 2% 7%  
8 ZZAA18 4% 3% 6%
9 ZZAA19 3%    
10 ZZAA20 7% 6% 4%
 
And you need one row of data per category:
 
                 Example 2
 
  A B C
1 Code Data Category
2 ZZAA12 5% Data1
3 ZZAA12 7% Data2
4 ZZAA12 9% Data3
5 ZZAA13 3% Data1
6 ZZAA14 7% Data1
7 ZZAA14 6% Data2
8 ZZAA14 4% Data3
9 ZZAA15 2% Data1
10 ZZAA15 3% Data2
11 ZZAA16 6% Data1
12 ZZAA16 4% Data2
13 ZZAA17 2% Data1
14 ZZAA17 7% Data2
15 ZZAA18 4% Data1
16 ZZAA18 3% Data2
17 ZZAA18 6% Data3
18 ZZAA19 3% Data1
19 ZZAA20 7% Data1
20 ZZAA20 6% Data2
21 ZZAA20 4% Data3

CODE

Sub ReOrganizeTable()
'JBeaucaire  (5/14/2010)
'Turns table data into columnar data
'Adds titles in row1 as a new column of values
Dim LR As Long, Rw As Long, Col As Long, LastCol As Long, CurRw As Long
Application.ScreenUpdating = False

LR = Range("A" & Rows.Count).End(xlUp).Row
Range("B:B").Insert xlShiftToRight

For Rw = LR To 2 Step -1
    If Range("D" & Rw) <> "" Then
        LastCol = Cells(Rw, Columns.Count).End(xlToLeft).Column
        Rows(Rw + 1).Resize(LastCol - 3).Insert xlShiftDown
        Range("A" & Rw).Resize(LastCol - 2) = Range("A" & Rw)
        Range("B" & Rw).Resize(LastCol - 2).Value = Range("C" & Rw).Resize(LastCol - 2).Value
        Range("C" & Rw).Resize(1, LastCol - 2).Copy
        Range("B" & Rw).Resize(LastCol - 2).PasteSpecial xlPasteAll, Transpose:=True
        Range("C1").Resize(1, LastCol - 2).Copy
        Range("C" & Rw).PasteSpecial xlPasteAll, Transpose:=True
    Else
        Range("C" & Rw).Copy Range("B" & Rw)
        Range("C1").Copy Range("C" & Rw)
    End If
Next Rw

Range("D1", Cells(Rows.Count, Columns.Count)).ClearContents
Range("B1:C1") = [{"Data","Category"}]
Cells.Columns.AutoFit
Application.ScreenUpdating = True
End Sub

 
 
PART 4 - Simple data-only table w/data types in row1 to 2-column format
 
 
A data-only table format with categories listed in row 1:
 
                               Example 1
 
  A B C D
1 SML MED LRG XLG
2 22 33 44 55
3 66 77 88 99
4 11 12 13 14
...is converted to a simple 2-column format:
 
                 Example 2
 
  A B
1 SML 22
2 MED 33
3 LRG 44
4 XLG 55
5 SML 66
6 MED 77
7 LRG 88
8 XLG 99
9 SML 11
10 MED 12
11 LRG 13
12 XLG 14

CODE

Sub ReOrganize3()
'Author:    Jerry Beaucaire
'Date:      11/10/2010
'Summary:   Reorganize a multivalue column database
'           into a single value per row database
'           Row1 becomes column A, column B hold values
Dim Titles  As Range
Dim LR      As Long
Dim Rw      As Long
Dim NC      As Long
Dim NR      As Long
 
'setup, titles are in row1
    Set Titles = Rows(1).SpecialCells(xlConstants)
    LR = Range("A" & Rows.Count).End(xlUp).Row
    NC = Cells(1, Columns.Count).End(xlToLeft).Column + 2
    NR = 1
    Application.ScreenUpdating = False
 
'Transpose values to single column
    For Rw = 2 To LR
        Range(Cells(Rw, "A"), Cells(Rw, NC - 2)).Copy
        Cells(NR, NC).PasteSpecial xlPasteAll, Transpose:=True
        NR = NR + NC - 2
    Next Rw
    
'add titles
    Titles.Copy
    Range(Cells(1, NC - 1), Cells(NR - 1, NC - 1)) _
            .PasteSpecial xlPasteAll, Transpose:=True
 
'Remove original data, cleanup
    Titles.EntireColumn.Delete xlShiftToLeft
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub
PART 5 - Multi-row arrays of random values into a single column
 
 
From this layout:
 
 
  A B C D E F
1 1a 1b 1c 1d 1e 1f
2 2a 2b        
3 3a 3b 3c 3d    
To this:
 
 
  A B
1 1a  
2 1b  
3 1c  
4 1d  
5 1e  
6 1f  
7 2a  
8 2b  
9 3a  
10 3b  
11 3c  
12 3d  
 

code

Sub ArrayToSingleColumn()
'Author:    Jerry Beaucaire
'Date:      8/12/2011
'Summary:   Arrange rows of random value into a single column of values
Dim Rw As Long, LR As Long
 
Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row
Columns(1).Resize(, 2).Insert xlShiftToRight
 
For Rw = 1 To LR
    Range(Cells(Rw, "C"), Cells(Rw, Columns.Count).End(xlToLeft)).Copy
    Range("A" &amp#59 Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues, Transpose:=True
Next Rw
 
Range("A1").Delete xlShiftUp
Range("A1").Select
Application.ScreenUpdating = True
End Sub

Nothing says "thanks" like a steak dinner!
 
PayPal - The safer, easier way to pay online!
 
Comments