Expand Info Vertically

[miky21]

Hello Everyone,

Need some help in setting up a large set of data which houses account numbers in one column with multiple account numbers listed in 1 cell and they are assigned to a person on the neighboring cell.

Example:

	A	B
1	812345678, 812312348	Dave
2	898765432, 867654326, 876765456	Mike

<tbody>
</tbody>

convert to

	A	B
1	812345678	Dave
2	812312348	Dave
3	898765432	Mike
4	867654326	Mike
5	876765456	Mike

<tbody>
</tbody>

and so on...

Any help is greatly appreciated. Thanks

******** type="cosymantecnisbfw" cotype="cs" id="SILOBFWOBJECTID" style="width: 0px; height: 0px; display: block;"></object>

 

[hiker95]

miky21,

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 a macro solution for you to consider that uses two arrays in memory, and, is based on your two screenshots.

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

Sample raw data:

Excel 2007
	A	B
1	812345678, 812312348	Dave
2	898765432, 867654326, 876765456	Mike
3
4
5
6
Sheet1

After the macro:

Excel 2007
	A	B
1	812345678	Dave
2	812312348	Dave
3	898765432	Mike
4	867654326	Mike
5	876765456	Mike
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, 07/21/2015, ME869958
Dim a As Variant, o As Variant
Dim i As Long, j As Long
Dim s, k As Long, mx As Long
Dim Addr As String
Application.ScreenUpdating = False
With Sheets("Sheet1")   '<-- you can change the sheet name here
  Addr = "A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row
  mx = Evaluate(Replace("MAX(IF(LEN(@),LEN(@)-LEN(SUBSTITUTE(@,"","",""""))+1,""""))", "@", Addr))
  a = .Range(Addr).Resize(, 2)
  ReDim o(1 To UBound(a, 1) * mx, 1 To 2)
  For i = 1 To UBound(a, 1)
    s = Split(a(i, 1), ", ")
    For k = LBound(s) To UBound(s)
      j = j + 1: o(j, 1) = s(k): o(j, 2) = a(i, 2)
    Next
  Next i
  .Range(Addr).Resize(, 2).Clear
  .Cells(1, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns(1).Resize(, UBound(o, 2)).AutoFit
End With
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, 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.

 

[miky21]

This works perfectly. Thanks for the quick reply. You are a life saver!!! ******** type="cosymantecnisbfw" cotype="cs" id="SILOBFWOBJECTID" style="width: 0px; height: 0px; display: block;"></object>

 

[hiker95]

miky21,

Thanks for the feedback.

You are very welcome. Glad I could help.

And, come back anytime.