Text Functions‎ > ‎

Column(s) to Rows

             Sample file for these macros: ColumnsToRows-ConsolidationMacros.xls

Part 1 - One column with data to row format


SPECIFICATIONS:
    1. Data in a single column
    2. Several rows represent a "set" of data that needs to go into a single row
    3. Each "set" is separated by blank cell(s)
                                         Example 1
  A B C D E
1 Name1        
2 Address1        
3 City1        
4 State1        
5 Zip1        
6          
7 Name2        
8 Address2        
9 City2        
10 State2        
11 Zip2        
12          
13 Name3        
14 Address3        
15 City3        
16 State3        
17 Zip3        

The data needs to be moved into this format:
                                        Example 2
  A B C D E
1 Name1 Address1 City1 State1 Zip1
2 Name2 Address2 City2 State2 Zip2
3 Name3 Address3 City3 State3 Zip3
4          
5          
6          
7          
8          
9          


This macro makes use of the AREAS() feature that deals with separated data individually. This only works because of the blank cells between datasets.

CODE

Option Explicit

Sub ReformatData()
'Jerry Beaucaire  2/8/2010
'Reorganize groups of data in column A into row format
Dim i As Long, RNG As Range

Application.ScreenUpdating = False
Set RNG = Columns("A:A").SpecialCells(xlCellTypeConstants)

    For i = 1 To RNG.Areas.Count
        RNG.Areas(i).Copy
        Range("B" & i).PasteSpecial xlPasteAll, Transpose:=True
    Next i

Columns(1).Delete xlShiftToLeft
Set RNG = Nothing
Application.ScreenUpdating = True
End Sub























Part 2 - One column with data, one column with duplicate values
to row format

SPECIFICATIONS:
    1. Values in one column, data in another single column
    2. Data may not be sorted
    3. Data starts in row2, row1 has "titles" for each column
    4. Based on matches in one column (A), the other columns are merged so all data is in one row for matched value
    5. Merged data can be in separate cells or merged into a single cell, the user can select the delimiter used each time (the default is pipe character)
                Example 1
  A B
1 Invoice # Item Codes
2 10467411 66
3 10467412 9
4 10467407 55
5 10467407 66
6 10467411 6
7 10467412 5
8 10467411 13
9 10467407 6

Needs to be in one of these formats:

                                  Example 2a   (use Consolidate macro)
  A B C D
1 Invoice # Item Codes Item Codes Item Codes
2 10467407 55 66 6
3 10467411 66 6 13
4 10467412 9 5  

                     Example 2b   (use ConsolidateMerge macro)
ABCD
1Invoice #Item Codes
21046740755|66|6
31046741166|6|11
4104674129|5


CODE

Option Explicit

Sub Consolidate()
'JBeaucaire  (9/18/2009)
'Columnar data is Sorted/Matched by column A values, merge all other cells into row format
Dim LastRow As Long, NextCol As Long
Dim LastCol As Long, Rw As Long, Cnt As Long
Dim delRNG As Range
Application.ScreenUpdating = False

'Sort data
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes
   
'Seed the delete range
    Set delRNG = Range("A" & LastRow + 10)
   
'Group matching names
    For Rw = LastRow To 2 Step -1
        If Cells(Rw, "A").Value = Cells(Rw - 1, "A").Value Then
            Range(Cells(Rw, "B"), Cells(Rw, Columns.Count).End(xlToLeft)).Copy _
                Cells(Rw - 1, Columns.Count).End(xlToLeft).Offset(0, 1)
            Set delRNG = Union(delRNG, Range("A" & Rw))
        End If
    Next Rw

'Delete unneeded rows all at once
    delRNG.EntireRow.Delete (xlShiftUp)
    Set delRNG = Nothing

'Add titles
    NextCol = Cells(1, Columns.Count).End(xlToLeft).Column + 1
    LastCol = Cells(1, 1).CurrentRegion.Columns.Count
    Range("B1", Cells(1, NextCol - 1)).Copy Range(Cells(1, NextCol), Cells(1, LastCol))

Cells.Columns.AutoFit
Application.ScreenUpdating = True
End Sub

 

Text Box

Option Explicit
 
Sub ConsolidateMerge()
'Jerry Beaucaire  (8/23/2012)
'Columnar data is Sorted/Matched by column A values, merge column B into a single cell row format
Dim LR As Long, Delim As String
 
'Allow user to set the Delimiter
    Delim = Application.InputBox("Merge column B values with what delimiter?", "Delimiter", "|", Type:=2)
    If Delim = "False" Then Exit Sub
    If Delim = "" Then
        If MsgBox("You chose a blank delimiter, this will merge column B value into a single continuous string. Proceed?", _
            vbYesNo, "Merge with no delimiter") = vbNo Then Exit Sub
    End If
   
'Sort data
    Application.ScreenUpdating = False
    LR = Range("A" & Rows.Count).End(xlUp).Row
    Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes
 
'Concatenate column B values so last matching row in each group has all values
    With Range("E2:E" & LR)
        .FormulaR1C1 = "=IF(RC1=R[-1]C1, R[-1]C & " & """" & Delim & """" & " & RC2, RC2)"
        .Value = .Value
        .Copy Range("B2")
        .FormulaR1C1 = "=IF(RC1=R[1]C1, """", 1)"
        Range("E:E").AutoFilter 1, "<>1"
        .EntireRow.Delete xlShiftUp
        .EntireColumn.Clear
    End With
ActiveSheet.AutoFilterMode = False
Columns.AutoFit
Application.ScreenUpdating = True
End Sub



Part 3 - Many columns with data, one column with duplicate values to row format

SPECIFICATIONS:
  1. Values in one column, data in many columns, undetermined number of columns
  2. Value column with duplicates may not be sorted
  3. Based on matches in one column (A), the other columns are merged so all data is in one row for matched value
  4. As data is merged up, if any two values are in same column, the upper value is retained.
                  Example 1
  A B C D E
1 Equipment Data1 Data2 Data3 Data4
2 MachineY   5    
3 MachineZ 3      
4 MachineX   5    
5 MachineZ       1
6 MachineX     3  
7 MachineY 3      
8 MachineY       7
9 MachineX 4      
10 MachineZ   2    
11 MachineY     7  
12 MachineX       2

Needs to be merged down to one of these formats:
                                  Example 2a
  A B C D E
1 Equipment Data1 Data2 Data3 Data4
2 MachineX 4
5
3
    2
3 MachineY 3
5
7 7
4 MachineZ 3 2

 1
5          
6          

Example 2b
ABCD
1Invoice #Item CodesItem CodesItem Codes
21046740755|66|6666
31046741166|6|13613
4104674129|55


CODE

Option Explicit

Sub MergeAnyData()
'Jerry Beaucaire  (4/26/2010)
'For duplicated values in column A data is sorted and merged
Dim LastRow As Long, Rw As Long
Dim LastCol As Long, Col As Long
Dim delRNG As Range
Application.ScreenUpdating = False

LastRow = Range("A" & Rows.Count).End(xlUp).Row
LastCol = Cells(1, Columns.Count).End(xlToLeft).Column

'Sort table by column A
    Range("A1", Cells(LastRow, LastCol)).Sort Key1:=Range("A1"), _
        Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortTextAsNumbers

'start the delete rng
    Set delRNG = Range("A" & LastRow + 10)
    
'Merge data and mark rows for deletion at the end
    On Error Resume Next
    For Rw = LastRow To 3 Step -1
        If Range("A" & Rw) = Range("A" & Rw - 1) Then
            For Col = 2 To LastCol
                If Cells(Rw - 1, Col) = "" Then Cells(Rw - 1, Col) = Cells(Rw, Col)
            Next Col
            Set delRNG = Union(delRNG, Range("A" & Rw))
        End If
    Next Rw

'Delete and cleanup
    delRNG.EntireRow.Delete xlShiftUp
    Set delRNG = Nothing
    Application.ScreenUpdating = True
End Sub



Part 4 - Merge numeric values in one column matching values in another

SPECIFICATIONS:
    1. Data in several columns
    2. Match values in column A
    3. Merge numeric value(s) in following column(s) (this will work if only 1 QTY column, or several)
    4. Delete duplicate rows leaving consolidated set of data
                  Example 1
  A B C D
1 Item QTY1 QTY2 QTY3
2 Cats 5 6 7
3 Dogs 6 5 9
4 Birds 5 7 9
5 Cats 66 2 4
6 Dogs 2 6 7
7 Birds 34 7 8
8 Cats 5 6 88
9 Dogs 22 66 7
10 Birds 33 6 7

The data merges down to this:

                       Example 2
  A B C D
1 Item QTY1 QTY2 QTY3
2 Cats 76 14 99
3 Dogs 30 77 23
4 Birds 72 20 24


CODE

Option Explicit

Sub MergeItems()
'Jerry Beaucaire  3/11/2010    (updated 6/21/2010)
'Merge all QTY columns for same items
Dim LastRow As Long, Rw As Long
Dim LastCol As Long, Col As Long
Dim delRNG As Range
Application.ScreenUpdating = False

LastRow = Range("A" & Rows.Count).End(xlUp).Row
LastCol = Cells(1, Columns.Count).End(xlToLeft).Column

Set delRNG = Range("A" & LastRow + 10)      'seed the delRNG so it's easier to use

For Rw = 2 To LastRow
    'for each row, see if this is the FIRST row this column A value occurs
    'if not, set this duplicate row to be deleted later
    If Application.WorksheetFunction.CountIf(Range("A2:A" & Rw), _
        Range("A" & Rw)) > 1 Then
            Set delRNG = Union(delRNG, Range("A" & Rw))
    Else
    'if it IS the first time the column A value occurs, then run across this row
    'and for each column do a SUMIF formula to get the values from all rows with
    'this value and place that sum into the first row. This row will NOT be deleted later
        For Col = 2 To LastCol
            Cells(Rw, Col) = Application.WorksheetFunction.SumIf(Range("A:A"), _
                Range("A" & Rw), Columns(Col))
        Next Col
    End If
Next Rw

delRNG.EntireRow.Delete xlShiftUp       'delete all the unneeded duplicate rows
Set delRNG = Nothing
Application.ScreenUpdating = True
End Sub



Part 5 - Separate columns of data formatted into a two-column format

SPECIFICATIONS:
    1. Data in several columns
    2. Header in row 1 for all sets of data
    3. Create a row format table in 2-columns headers in column 1 and data values in column 2
                                   BEFORE
  A B C
1 Example 1 Example 2 Example 3
2 hello thanks for the help
3 hi appreciated on this sheet
4 hey   it will save
5     me time

                     AFTER
  A B
1 Example 1 hello
2 Example 1 hi
3 Example 1 hey
4 Example 2 thanks
5 Example 2 appreciated
6 Example 3 for the help
7 Example 3 on this sheet
8 Example 3 it will save
9 Example 3 me time


CODE

Option Explicit

Sub ColumnsToRows()
'Author:    Jerry Beaucaire
'Date:      6/27/2010
'Summary:   Multiple Columns of data with a header formatted
'           into two columns, headers in column1, data in 2
Dim LC      As Long
Dim dCol    As Long
Dim NR      As Long
Dim CpyRNG  As Range
Application.ScreenUpdating = False

'Insert new blank columns
    Range("A:B").Insert xlShiftToRight

'Where to place next row of copied data
    NR = 1
   
'Last column of data
    LC = Cells(1, Columns.Count).End(xlToLeft).Column
   
'Loop through each column
    For dCol = 3 To LC
        Set CpyRNG = Range(Cells(2, dCol), Cells(Rows.Count, dCol)) _
            .SpecialCells(xlCellTypeConstants)
        CpyRNG.Copy Range("B" & NR)
        Cells(1, dCol).Copy Range("A" & NR).Resize(CpyRNG.Rows.Count)
        NR = NR + CpyRNG.Rows.Count
    Next dCol
   
'Cleanup
    Range(Cells(1, 3), Cells(Rows.Count, LC)).Clear
    Columns.AutoFit
    Set CpyRNG = Nothing
    Application.ScreenUpdating = True
End Sub
    




Part 6 - Incoming two-column format data parsed to a new sheet with RANDOM placement

SPECIFICATIONS:
    1. Incoming data in two columns, column A always lists the correct Category, column B is the data to parse
    2. Data in column B is parsed to OUTPUT sheet based on the category
    3. The OUTPUT sheet can list the category header in ANY random column, must be spotted as we go
    4. Not all groups of incoming data include all categories
    5. Parts of code that may need editing are highlighted in red
                                               Part6-Data
 AB
1RecordDetails
2NameName1
3Emailemai1@somedomain.com
4Phone8055523115
5GenderFemale
6ModeFull Time
7Current LocationAll Mumbai
8Preferred LocationsAll Mumbai
9Date of Registration14th Sep 2011
10  
11NameName2
12Phone9533866967
13Desired CourseMBA/PGDM
14ModeFull Time
15Current LocationAndhra Pradesh - Other
16Preferred LocationsHyderabad
17Date of Registration14th Sep 2011

                                              Part6-OUT(partial example output)
 EFGHIJK
1NameEmailPhoneGenderDesired CourseModeCurrent Location
2Name1emai1@somedomain.com8055523115Female Full TimeAll Mumbai
3Name2 9533866967 MBA/PGDMFull TimeAndhra Pradesh - Other

CODE

Option Explicit

Sub ColumnsToRowsRandomColumns()
'Author:    Jerry Beaucaire     (9/15/2011)
'Summary:   incoming two-column data with category in column A is parsed
'           to a new sheet with categories in random columns in the OUTPUT sheet
'           Not all incoming data includes all categories
Dim LR As Long, NR As Long, Rw As Long
Dim wsData As Worksheet, wsOUT As Worksheet
Dim HdrCol As Range, Hdr As String, strRESET As String

Set wsData = Sheets("Part6-Data")   'source data
Set wsOUT = Sheets("Part6-OUT")    'output sheet
strRESET = "Name"               'this value will cause the record row to increment

LR = wsData.Range("A" & Rows.Count).End(xlUp).Row   'end of incoming data
Set HdrCol = wsOUT.Range("1:1").Find(strRESET, _
            LookIn:=xlValues, LookAt:=xlWhole)      'find the reset category column
If HdrCol Is Nothing Then
    MsgBox "The key string '" & strRESET & _
        "' could not be found on the output sheet."
    Exit Sub
End If

NR = wsOUT.Cells(Rows.Count, HdrCol.Column) _
            .End(xlUp).Row      'current output end of data
Set HdrCol = Nothing

On Error Resume Next
For Rw = 1 To LR
    Hdr = wsData.Range("A" & Rw).Value
    If Hdr = "Name" Then NR = NR + 1
    If Hdr <> "" And Hdr <> "Record" Then
        Set HdrCol = wsOUT.Range("1:1").Find(Hdr, _
                LookIn:=xlValues, LookAt:=xlWhole)
        If Not HdrCol Is Nothing Then
            wsOUT.Cells(NR, HdrCol.Column).Value _
                    = wsData.Range("B" & Rw).Value
            Set HdrCol = Nothing
        End If
    End If
Next Rw

wsOUT.Columns.AutoFit
End Sub




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