Copying from one sheet and pasting a parsed result into another sheet with new duplicate rows

[theloveofwisdom]

Salutations!!


I'm looking for a solution to this problem in vba. I'd like to take data from the chart below which is in sheet 1....

	First Name	Last Name	Number of Tickets	Ticket Numbers
	Annie	smith	1	1
	Mari	jones	2	2;3
	Steve	smith	3	4;5;6
	Nick	jones	4	7;8;9;10
	Nick	smith	5	11;12;13;14;15

<tbody>
</tbody>

..... and parse the delimiter and paste it as such into sheet 2 as below.

First Name	Last Name	Number of Tickets	Ticket Numbers
Annie	smith	1	1
Mari	jones	2	2
Mari	jones	2	3
Steve	smith	3	4
Steve	smith	3	5
Steve	smith	3	6
Nick	jones	4	7
Nick	jones	4	8
Nick	jones	4	9
Nick	jones	4	10
Nick	smith	5	11
Nick	smith	5	12
Nick	smith	5	13
Nick	smith	5	14
Nick	smith	5	15

<tbody>
</tbody>

Any input would be much appreciated!


Godspeed.

 

[Peter_SSs]

Assuming headings already exist on Sheet2 but anything else on that sheet can be deleted to receive the new results.

Test in a copy of your workbook.

Sub Rearrange()
  Dim a, b
  Dim i As Long, j As Long, k As Long
  
  With Sheets("Sheet1")
    a = .Range("A2", .Range("D" & .Rows.Count).End(xlUp)).Value
  End With
  ReDim b(1 To 4, 0 To 0)
  For i = 1 To UBound(a)
    ReDim Preserve b(1 To 4, 1 To UBound(b, 2) + a(i, 3))
    For j = 1 To a(i, 3)
      k = k + 1
      b(1, k) = a(i, 1)
      b(2, k) = a(i, 2)
      b(3, k) = a(i, 3)
      b(4, k) = Split(a(i, 4), ";")(j - 1)
    Next j
  Next i
  With Sheets("Sheet2")
    .UsedRange.Offset(1).ClearContents
    .Range("A2:D2").Resize(UBound(b, 2)).Value = Application.Transpose(b)
  End With
End Sub

 

[hiker95]

theloveofwisdom,

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

2. Are you using a PC or a Mac?

Here is a macro for you to consider that uses two arrays in memory, and, will adjust the varying number of raw data rows in Sheet1.

Sample raw data:

Excel 2007
	A	B	C	D
1	First Name	Last Name	Number of Tickets	Ticket Numbers
2	Annie	smith	1	1
3	Mari	jones	2	2;3
4	Steve	smith	3	4;5;6
5	Nick	jones	4	7;8;9;10
6	Nick	smith	5	11;12;13;14;15
7
Sheet1

After the macro in Sheet2:

Excel 2007
	A	B	C	D
1	First Name	Last Name	Number of Tickets	Ticket Numbers
2	Annie	smith	1	1
3	Mari	jones	2	2
4	Mari	jones	2	3
5	Steve	smith	3	4
6	Steve	smith	3	5
7	Steve	smith	3	6
8	Nick	jones	4	7
9	Nick	jones	4	8
10	Nick	jones	4	9
11	Nick	jones	4	10
12	Nick	smith	5	11
13	Nick	smith	5	12
14	Nick	smith	5	13
15	Nick	smith	5	14
16	Nick	smith	5	15
17
Sheet2

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/21/2015, ME903910
Dim a As Variant, i As Long, lr As Long
Dim o As Variant, j As Long
Dim s, t As Long, n As Long
Application.ScreenUpdating = False
With Sheets("Sheet1")
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  a = .Range("A2:D" & lr).Value
  n = Evaluate("=Sum(C2:C" & lr & ")")
  ReDim o(1 To n, 1 To 4)
End With
For i = LBound(a, 1) To UBound(a, 1)
  If InStr(a(i, 4), ";") Then
    s = Split(a(i, 4), ";")
    For t = LBound(s) To UBound(s)
      j = j + 1
      o(j, 1) = a(i, 1): o(j, 2) = a(i, 2): o(j, 3) = a(i, 3)
      o(j, 4) = s(t)
    Next t
  Else
    j = j + 1
    o(j, 1) = a(i, 1): o(j, 2) = a(i, 2)
    o(j, 3) = a(i, 3): o(j, 4) = a(i, 4)
  End If
Next i
With Sheets("Sheet2")
  .Columns("A:D").ClearContents
  With .Range("A1:D1")
    .Value = Sheets("Sheet1").Range("A1:D1").Value
    .Font.Bold = True
  End With
  .Cells(2, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns("A:D").AutoFit
  .Activate
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.

 

[theloveofwisdom]

This was perfect. Thank you!

 

[hiker95]

theloveofwisdom,

Thanks for the feedback.

You are very welcome. Glad we could help.

And, come back anytime.