Merge Multiple rows into a single row

[contemporary]

Hi All,

I've searched for this, perhaps not hard enough! but I haven't see it covered the way I'm looking for it

I've a csv file like this

003R91165A4	Brand	Xerox
003R91165A4	Colour	White
003R91165A4	Dimensions	210x297mm
003R91165A4	Eco-Aware	Yes
003R91165A4	For Copiers	Yes
003R91165A4	For Laser Printers	Yes
003R91165A4	Grammage	80gsm
003R91165A4	Manufacturer	Xerox
003R91165A4	Recycled Product	100% Recycled Material
003R91165A4	Size	A4
003R91165A4	Type	Plain Paper
003R91166A3	Brand	Xerox
003R91166A3	Colour	White
003R91166A3	Dimensions	297x420mm
003R91166A3	Eco-Aware	Yes
003R91166A3	Manufacturer	Xerox
003R91166A3	Recycled Product	100% Recycled
003R91166A3	Size	A3
003R91166A3	Type	Plain Paper

<tbody>
</tbody>

and I am looking to get excel to combine the rows so that i can get it to show like this

003R91165A4

Brand

Xerox

Colour

White

Dimensions

210x297mm

Eco-Aware

Yes

For Copiers

Yes

For Laser Printers

Yes

Grammage

80gsm

Manufacturer

Xerox

Recycled Product

100% Recycled Material

Size

A4

Type

Plain Paper

003R91166A3

Brand

Xerox

Colour

White

Dimensions

297x420mm

Eco-Aware

Yes

Manufacturer

Xerox

Recycled Product

100% Recycled

Size

A3

Type

Plain Paper

<tbody>
</tbody>

Any suggestions or tips greatly appreciated

 

[Trebor76]

Hi contemporary,

Welcome to the forum!!

Maybe a little clunky, but this should do the trick:

Option Explicit
Sub Macro1()

    Const lngStartRow As Long = 1 'Starting (static) row number for your data. Change to suit.

    Dim rngMyCell As Range
    Dim lngLastRow As Long
    Dim lngMyRow As Long
    Dim lngMyCol As Long
    Dim clnUniqueValues As New Collection
    Dim varUniqueValue As Variant
    
    Application.ScreenUpdating = False
    
    lngLastRow = Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    'Create an array of unique items in the range
    For Each rngMyCell In Range("A" & lngStartRow & ":A" & lngLastRow)
        On Error Resume Next 'Turn error reporting off as we're not interested in the 'Run-time error '457' This key is already associated with an element of this collection' error message as we only want unique entries anyway.
            clnUniqueValues.Add rngMyCell.Value, CStr(rngMyCell.Value)
            Err.Clear
        On Error GoTo 0
    Next rngMyCell
    
    'Now colour the interior of each unique value an unique colour. Note the colour assigned to each unique value will be different each time.
    For Each varUniqueValue In clnUniqueValues
        If lngMyRow = 0 Then
            lngMyRow = lngStartRow
        Else
            lngMyRow = lngMyRow + 1
        End If
        For Each rngMyCell In Range("A" & lngStartRow & ":A" & lngLastRow)
            If rngMyCell = varUniqueValue Then
                lngMyCol = Cells(lngMyRow, Columns.Count).End(xlToLeft).Column + 1
                Cells(lngMyRow, lngMyCol) = Range("B" & rngMyCell.Row)
                lngMyCol = Cells(lngMyRow, Columns.Count).End(xlToLeft).Column + 1
                Cells(lngMyRow, lngMyCol) = Range("C" & rngMyCell.Row)
            End If
        Next rngMyCell
    Next varUniqueValue
    
    'Put each unique item back in Col. C
    Range("C1").EntireColumn.ClearContents 'Clear existing contents
    lngMyRow = lngStartRow
    For Each varUniqueValue In clnUniqueValues
        Range("C" & lngMyRow) = varUniqueValue
        lngMyRow = lngMyRow + 1
    Next varUniqueValue
    
    'Delete Col's A and B
    Range("A1:B1").EntireColumn.Delete
        
    Application.ScreenUpdating = True

End Sub

Just run it initially on a copy of your data as if the results are not as expected they cannot be undone (although you could close your workbook without saving).

Regards,

Robert

 

[hiker95]

contemporary,

Welcome to the MrExcel forum.

1. What version of Excel, and, Windows are you using?

2. Are you using a PC or a Mac?

Here is another macro solution for you to consider, that uses one array in memory, and, writes the results to a new worksheet Results.

3. Do you want the results to replace the raw data? If so, I can adjust the macro.

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

Sample raw data:

Excel 2007
	A	B	C
1	003R91165A4	Brand	Xerox
2	003R91165A4	Colour	White
3	003R91165A4	Dimensions	210x297mm
4	003R91165A4	Eco-Aware	Yes
5	003R91165A4	For Copiers	Yes
6	003R91165A4	For Laser Printers	Yes
7	003R91165A4	Grammage	80gsm
8	003R91165A4	Manufacturer	Xerox
9	003R91165A4	Recycled Product	100% Recycled Material
10	003R91165A4	Size	A4
11	003R91165A4	Type	Plain Paper
12	003R91166A3	Brand	Xerox
13	003R91166A3	Colour	White
14	003R91166A3	Dimensions	297x420mm
15	003R91166A3	Eco-Aware	Yes
16	003R91166A3	Manufacturer	Xerox
17	003R91166A3	Recycled Product	100% Recycled
18	003R91166A3	Size	A3
19	003R91166A3	Type	Plain Paper
20
Sheet1

After the macro in the new worksheet Results (in 4 screenshots to because of the width of the resulting columns):

Excel 2007
	A	B	C	D	E	F
1	003R91165A4	Brand	Xerox	Colour	White	Dimensions
2	003R91166A3	Brand	Xerox	Colour	White	Dimensions
3
Results

Excel 2007
	G	H	I	J	K	L
1	210x297mm	Eco-Aware	Yes	For Copiers	Yes	For Laser Printers
2	297x420mm	Eco-Aware	Yes	Manufacturer	Xerox	Recycled Product
3
Results

Excel 2007
	M	N	O	P	Q	R
1	Yes	Grammage	80gsm	Manufacturer	Xerox	Recycled Product
2	100% Recycled	Size	A3	Type	Plain Paper
3
Results

Excel 2007
	S	T	U	V	W	X
1	100% Recycled Material	Size	A4	Type	Plain Paper
2
3
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).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub ReorgData()
' hiker95, 07/27/2015, ME871309
Dim w1 As Worksheet, wr As Worksheet
Dim o As Variant, j As Long, c As Long
Dim r As Long, lr As Long, rr As Long, n As Long, nmax As Long, ng 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
  For r = 1 To lr
    ng = ng + 1
    n = Application.CountIf(.Columns(1), .Cells(r, 1).Value)
    If n > nmax Then nmax = n
    r = r + n - 1
  Next r
  ReDim o(1 To ng, 1 To (nmax * 2) + 1)
  For r = 1 To lr
    n = Application.CountIf(.Columns(1), .Cells(r, 1).Value)
    j = j + 1: c = 1
    o(j, 1) = .Cells(r, 1).Value
    For rr = r To r + n - 1
      c = c + 1
      o(j, c) = .Cells(rr, 2).Value
      c = c + 1
      o(j, c) = .Cells(rr, 3).Value
    Next rr
    r = r + n - 1
  Next r
End With
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wr = Sheets("Results")
wr.UsedRange.Clear
With wr
  .Cells(1, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns(1).Resize(, UBound(o, 2)).AutoFit
  .Activate
End With
Application.ScreenUpdating = False
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.

 

[hiker95]

contemporary,

Here is another macro solution for you to consider, that uses one array in memory, that will replace the raw data with the results.

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

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 ReorgDataV2()
' hiker95, 07/27/2015, ME871309
Dim o As Variant, j As Long, c As Long
Dim r As Long, lr As Long, rr As Long, n As Long, nmax As Long, ng As Long
Application.ScreenUpdating = False
With Sheets("Sheet1")   '<-- you can change the sheet name here
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  For r = 1 To lr
    ng = ng + 1
    n = Application.CountIf(.Columns(1), .Cells(r, 1).Value)
    If n > nmax Then nmax = n
    r = r + n - 1
  Next r
  ReDim o(1 To ng, 1 To (nmax * 2) + 1)
  For r = 1 To lr
    n = Application.CountIf(.Columns(1), .Cells(r, 1).Value)
    j = j + 1: c = 1
    o(j, 1) = .Cells(r, 1).Value
    For rr = r To r + n - 1
      c = c + 1
      o(j, c) = .Cells(rr, 2).Value
      c = c + 1
      o(j, c) = .Cells(rr, 3).Value
    Next rr
    r = r + n - 1
  Next r
  .UsedRange.Clear
  .Cells(1, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns(1).Resize(, UBound(o, 2)).AutoFit
End With
Application.ScreenUpdating = False
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 ReorgDataV2 macro.

 

[contemporary]

Guys, thank you so much for your assistance with this, I really appreciate it.

I have just one small question, I have come columns (the A column) which are numeric only and begin with 00 so excel decides to strip out the leading 00, is there anyway of modifying the macros to allow the leading zeros to be retained?

I have access to two different versions of excel, Excel for Mac 2011 or Excel 2013 on Win 8.1

Thanks again

 

[hiker95]

Guys, thank you so much for your assistance with this, I really appreciate it.

contemporary,

Thanks for the feedback.

You are very welcome. Glad we could help.

 

[hiker95]

contemporary,

Have you tried either of my two macros?

 

[hiker95]

I have just one small question, I have come columns (the A column) which are numeric only and begin with 00 so excel decides to strip out the leading 00, is there anyway of modifying the macros to allow the leading zeros to be retained?

contemporary,

It sounds like we have not seen your actual raw data, and, screenshots will not show what your actual raw data looks like.

So that we can get it right on the next try, can we see your actual raw data workbook/worksheet(s)?

The following is a free site:

You can upload your workbook to (the BLUE link-->) Box Net ,

sensitive data changed

mark the workbook for sharing

and provide us with a link to your workbook.

 

[contemporary]

contemporary,

It sounds like we have not seen your actual raw data, and, screenshots will not show what your actual raw data looks like.

So that we can get it right on the next try, can we see your actual raw data workbook/worksheet(s)?

The following is a free site:

You can upload your workbook to (the BLUE link-->) Box Net ,

sensitive data changed

mark the workbook for sharing

and provide us with a link to your workbook.

Thanks again, I hope dropbox is ok for you

https://www.dropbox.com/s/yr07b0j02me2ppp/mrexcel.csv?dl=0

 

[hiker95]

contemporary,

Thanks for the raw data workbook.

1. Do you want the macro to write the results to a new worksheet Results?

2. Or, do you want the raw data cleared, and, the results to be written beginning in cell A1, on the raw data worksheet?