Reorganize Data

[Veronika91]

Hi,
I have a list of 300 accounts in the first columns and the contacts in the second column. Each account can have multiple contacts to it so it will appear in rows multiple times:
Company1 - email@email.com
Company 1 - email2@email.com
Company 2 - email@email.com
Company 2 - email2@email.com
Company 2 - email3@email.com
What should I do if I want to show accounts in the row A1 without being duplicated and the email addresses on the same rows as accounts just in cells A2, A3... Sort of "transpose"

Any idea?
I know it may be a really silly question...

 

[Rick Rothstein]

Give this macro a try...

[table="width: 500"]
[tr]
	[td]Sub RearrangeContacts()
  Dim X As Long, Data As Variant
  Data = Range("A1", Cells(Rows.Count, "B").End(xlUp))
  With CreateObject("Scripting.Dictionary")
    For X = 1 To UBound(Data)
      .Item(Data(X, 1)) = Trim(.Item(Data(X, 1)) & " " & Data(X, 2))
    Next
    Columns("A:B").Clear
    Range("A1").Resize(.Count) = Application.Transpose(.Keys)
    Range("B1").Resize(.Count) = Application.Transpose(.Items)
    Columns("B").TextToColumns , xlDelimited, , , False, False, False, True, False
    Columns("B").Resize(, UBound(Data)).AutoFit
  End With
End Sub[/td]
[/tr]
[/table]

 

[hiker95]

Veronika91,

Welcome to the MrExcel forum.

Here is another macro solution for you to consider.

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 RearrangeContacts_V2()
' hiker95, 08/08/2017, ME1017972
Dim c As Range, rng As Range, v As Variant, o As Variant
Dim i As Long, n As Long, lc As Long
Set rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
ReDim o(1 To rng.Count, 1 To Columns.Count)
With CreateObject("Scripting.Dictionary")
  .CompareMode = vbTextCompare
  For Each c In rng
    If Not .Exists(c.Value) Then
      n = n + 1
      .Add c.Value, Array(n, 2)
      o(n, 1) = c.Value: o(n, 2) = c.Offset(, 1).Value
    Else
      v = .Item(c.Value)
      v(1) = v(1) + 1
      o(v(0), v(1)) = c.Offset(, 1)
      .Item(c.Value) = v
      i = Application.Max(v(1), i)
    End If
  Next
  rng.Resize(, 2).ClearContents
  Range("A1").Resize(.Count, i).Value = o
End With
Columns.AutoFit
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 RearrangeContacts_V2 macro.