Combine multiple rows that have the same id into one row with the moved data in separate cells

[4653]

I have a spreadsheet where in column A each row has an id assigned to particular companies. Each company may have 1 or more contacts with all of the contact info for the personnel listed in their respective row. If it matters, the number of contacts per company vary (could be up to 15) and personnel contact info extends out to column AQ. What I'm trying to figure out is how to take all of the matching id's and move all of the contact info for each respective personnel for the company to a single row and separate cells for each piece of information. If the company id has to move with the info that is fine as I can just delete that column for each occurrence after the move. Any help would be greatly appreciated. Basically it currently looks like this:

1	John	123				
1	Brad	456
1	William	789
2	Brian	987
2	Jim	654
	I need it to look like this
1	John	123	Brad	456	William	789
2	Brian	987	Jim	654

<tbody>
</tbody>

 

[mdexter57]

4653,

Thanks to jbeaucaire's input.

Sample raw data:

Excel 2007

	A	B	C	D	E	F	G
1	1	John	123
2	1	Brad	456
3	1	William	789
4	2	Brian	987
5	2	Jim	654
6

<colgroup><col style="width: 25pxpx"><col><col><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Sheet1​

And, after the new macro:

Excel 2007

	A	B	C	D	E	F	G
1	1	John	123	Brad	456	William	789
2	2	Brian	987	Jim	654
3
4
5
6

<colgroup><col style="width: 25pxpx"><col><col><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Sheet1​

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).

Option Explicit
Sub ReorgDataV2()
' hiker95, 02/16/2014, ME758017
Dim r As Long, lr As Long, n As Long, rr As Long, nc As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
For r = 1 To lr
  n = Application.CountIf(Columns(1), Cells(r, 1).Value)
  If n > 1 Then
    For rr = r + 1 To r + n - 1
      nc = Cells(r, Columns.Count).End(xlToLeft).Column + 1
      Cells(r, nc).Resize(, 2).Value = Cells(rr, 2).Resize(, 2).Value
      Cells(rr, 1).Resize(, 3).ClearContents
    Next rr
  End If
  r = r + n - 1
Next r
On Error Resume Next
Range("A1:A" & lr).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
Columns.AutoFit
Application.ScreenUpdating = True
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

Then run the ReorgDataV2 macro.

Hi hiker95,

Good day to you. I was wondering if you can show me how to get this script to perform a slightly different end result.. I have pasted example boxes below for reference.

--mdexter57

Sample raw data:

Excel 2007

A	B	C	D	E	F	G	H
Title1	Title2	Title3	Title4
1	Brad	456	cat
1	Brad	789	dog
2	Brian	321	bird
2	Brian	654	bunny

<colgroup><col><col><col><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Sheet1​

And, after the macro:

Excel 2007

A	B	C	D	E	F	G	H
Title1	Title2	Title3	Title4	Title3	Title4	Title3	Title4
1	Brad	456	Cat	789	Dog
2	Brian	321	Bird	654	Bunny

<colgroup><col><col><col><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Sheet1​

 

[hiker95]

mdexter57,

Welcome to the MrExcel forum.

Are you using a PC or a Mac?


Sample raw data:

Excel 2007
	A	B	C	D	E	F
1	Title1	Title2	Title3	Title4
2	1	Brad	456	cat
3	1	Brad	789	dog
4	2	Brian	321	bird
5	2	Brian	654	bunny
6
Sheet1

After the macro:

Excel 2007
	A	B	C	D	E	F
1	Title1	Title2	Title3	Title4	Title3	Title4
2	1	Brad	456	cat	789	dog
3	2	Brian	321	bird	654	bunny
4
5
6
Sheet1

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, 11/14/2014, ME758017
Dim r As Long, lr As Long, rr As Long, n As Long, nc As Long
Dim lc As Long, c As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
For r = 2 To lr
  n = Application.CountIf(Columns(1), Cells(r, 1).Value)
  If n > 1 Then
    For rr = r + 1 To r + n - 1
      nc = Cells(r, Columns.Count).End(xlToLeft).Column + 1
      Cells(r, nc).Resize(, 2).Value = Cells(rr, 3).Resize(, 2).Value
      Cells(rr, 1).Resize(, 4).ClearContents
    Next rr
  End If
  r = r + n - 1
Next r
On Error Resume Next
Range("A1:A" & lr).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
lc = Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
For c = 5 To lc Step 2
  Cells(1, c).Resize(, 2).Value = Cells(1, 3).Resize(, 2).Value
Next c
Columns(5).Resize(, lc - 4).AutoFit
Application.ScreenUpdating = True
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

Then run the ReorgData macro.

 

[mdexter57]

Hi Hiker95,

I am using a PC and Office 2010

--mdexter57

 

[mdexter57]

Hiker95,

That is amazing. The code above worked exactly. Thank you so much.

mdexter57

 

[hiker95]

mdexter57,

Thanks for the feedback.

You are very welcome. Glad I could help.

And, come back anytime.

 

[craig_pyro]

Hi!

This macro looks to be exactly what I'm looking for, but with a simple variation.

Instead of 4 columns I have many more. It would be extremely useful if you could actually explain the macro (perhaps commented lines) and which values to edit in the loop to include more columns.

Assuming the first column is your reference, what changes to the macro need to be made to loop every 4 columns after, 5 columns after, 6 columns after etc?

Many thanks

mdexter57,

Welcome to the MrExcel forum.

Are you using a PC or a Mac?


Sample raw data:

Excel 2007

	A	B	C	D	E	F
1	Title1	Title2	Title3	Title4
2	1	Brad	456	cat
3	1	Brad	789	dog
4	2	Brian	321	bird
5	2	Brian	654	bunny
6

<colgroup><col style="width: 25pxpx"><col><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Sheet1​

After the macro:

Excel 2007

	A	B	C	D	E	F
1	Title1	Title2	Title3	Title4	Title3	Title4
2	1	Brad	456	cat	789	dog
3	2	Brian	321	bird	654	bunny
4
5
6

<colgroup><col style="width: 25pxpx"><col><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Sheet1​

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, 11/14/2014, ME758017
Dim r As Long, lr As Long, rr As Long, n As Long, nc As Long
Dim lc As Long, c As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
For r = 2 To lr
  n = Application.CountIf(Columns(1), Cells(r, 1).Value)
  If n > 1 Then
    For rr = r + 1 To r + n - 1
      nc = Cells(r, Columns.Count).End(xlToLeft).Column + 1
      Cells(r, nc).Resize(, 2).Value = Cells(rr, 3).Resize(, 2).Value
      Cells(rr, 1).Resize(, 4).ClearContents
    Next rr
  End If
  r = r + n - 1
Next r
On Error Resume Next
Range("A1:A" & lr).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
lc = Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
For c = 5 To lc Step 2
  Cells(1, c).Resize(, 2).Value = Cells(1, 3).Resize(, 2).Value
Next c
Columns(5).Resize(, lc - 4).AutoFit
Application.ScreenUpdating = True
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

Then run the ReorgData macro.

 

[hiker95]

craig_pyro,

Welcome to the MrExcel forum.

By your description of your dataset, it sounds much more complex, and, different then the original request by 4653.


Please do not post your questions in threads started by others - - this is known as thread hijacking.

Always start a new thread for your questions and, if you think it helps, provide a link to any other thread as a reference.

Start a new thread for your question and be sure to give it a search friendly title that accurately describes your need.

In your New Thread include:
1. the version of Excel you are using
2. Are you using a PC or a Mac?
3. a screenshot, NOT a picture/graphic, of the raw data, and, worksheet name
4. a screenshot, NOT a picture/graphic, of the results (manually formatted by you for the results you are looking for)


To post a small screen shot try one of the following:

Excel Jeanie
Download

MrExcel HTML Maker
https://onedrive.live.com/?cid=8cffdec0ce27e813&sc=documents&id=8CFFDEC0CE27E813!189

Borders-Copy-Paste
http://www.mrexcel.com/forum/about-board/444901-how-create-table-like-aladin.html#post2198045

To test the above:
Test Here


Or, you can upload your workbook to Box Net,
sensitive data changed
mark the workbook for sharing
and provide us with a link to your workbook.


Then send me a Private Message, with a link to your New Thread, and, I will have a look.