Duplicate Row and Rename If Column Contains Value

[migos]

Hi I need help for a fairly simple issue, but am very inexperienced with VBA. I'm currently assisting my team with tracking sales activities, however the log is updated manually and the sales activities are sometimes performed by more than one sales person. As you can see in the attached the Sales Person (Column B) will occasionally have a "/" to define the multiple persons involved. The entry would all be completed via Data Validation, however I would like to keep the solution dynamic as in the future different combinations would arise (i.e. sales activity by "Chris/Jeff"etc.). Essentially I am looking for a simple VBA macro that would first duplicate the whole sheet, and then find which rows in column B contained "/" and duplicate the row directly beneath for as many "/" as there are. For example if the Sales Person column had "Jeff/Brian/Chris", the macro would copy and paste the whole row twice below that line, and rename column B in order of the names presented (i.e. the copied line would change column B from "Jeff/Brian/Chris" to "Jeff", the first copied row below column B "Brian", and second copied line column B would be "Chris").

Thank you in advance!

[xladept]

Try this:

Sub migos(): Dim S As String, r As Long, Z, n As Long
r = 2: Do Until Cells(r, 2) = "": S = Cells(r, 2): Z = Split(S, "/")
                        If UBound(Z) Then
    Cells(r + 1, 1).Resize(UBound(Z), 6).Insert: Cells(r, 2) = Z(0)
For n = 1 To UBound(Z): Cells(r + n, 1).Resize(1, 6).Value = _
Cells(r, 1).Resize(1, 6).Value: Cells(r + n, 2).Value = Z(n): Next n
End If: r = r + n + 1: n = 0: Loop
End Sub

[migos]

Thank you so much. Gave you Reputation but I'm new so I'm not sure if it worked lol

[migos]

Sorry there's one issue with your code! If there are two multiple items in a row, the code will not work on the second row. For example in the screenshot, the last row (David/Chris/Jeff) will not be split using the code. Thank you in advance again!Capture.JPG

[xladept]

Hi migos,

You're welcome and thanks for the rep!

Try this version:

Sub migosX(): Dim S As String, r As Long, Z, n As Long
r = 2: Do Until Cells(r, 2) = "": S = Cells(r, 2): Z = Split(S, "/")
            If UBound(Z) Then
    Cells(r + 1, 1).Resize(UBound(Z), 6).Insert: Cells(r, 2) = Z(0)
For n = 1 To UBound(Z): Cells(r + n, 1).Resize(1, 6).Value = _
Cells(r, 1).Resize(1, 6).Value: Cells(r + n, 2).Value = Z(n)
Next n: r = r + n
            Else: r = r + 1: End If: n = 0: Loop
End Sub

[migos]

The data I'm working with is in a Excel Table Format, so Error 1004 arises when I attempt to run this code. Would you be able to tweak this code so that the inserted row(s) are added to the bottom of last row of the table instead of directly beneath the original row? I'm assuming this will prevent the error 1004 from occurring as you are simply adding a new row? Please correct me if I'm wrong. Thank you again in advance!

[migos]

Alternatively, since this table will be feeding data into a pivot table. Would it be possible to simply get the pivot table to recognize that the "/" signifies a separate line item? I'm simply using the Count function within the pivot table.

[xladept]

Hi migos,

Can you post a more representative sample workbook?

[migos]

Sure attached are the error message the I receive, the line of code that it highlights, a before (current)state, and an after (ideal solution) state.
The solution does not need to be exactly like the "After" screenshot, the duplicated rows can be placed simply at the bottom of the entire table, again the table is 100's of rows long so a "End.(xlUp).Row" solution would work if you could help with that?
Thank you again.

Sub Procedure1()
 Dim S As String, r As Long, Z, n As Long
    r = 4: Do Until Cells(r, 4) = "": S = Cells(r, 4): Z = Split(S, "/")
            If UBound(Z) Then
    Cells(r + 1, 1).Resize(UBound(Z), 20).Insert: Cells(r, 4) = Z(0)
    For n = 1 To UBound(Z): Cells(r + n, 1).Resize(1, 20).Value = _
    Cells(r, 1).Resize(1, 20).Value: Cells(r + n, 4).Value = Z(n)
    Next n: r = r + n
            Else: r = r + 1: End If: n = 0: Loop
End Sub

Error 1004.JPG
1004-2.JPG

Before.JPG BEFORE

After.JPG

[xladept]

If you'll post a workbook that's representative (with the table), I'll try to tweak it. But I'll be going to work soon, so I may not get to it today

[migos]

No worries, just whenever you can get it back to me at your earliest convenience. I don't I can post it here. Could I get your email to send it to you?

[xladept]

Hi migos,

This ran with the new row and column assignments as in your latest sample:

Sub migosX(): Dim s As String, r As Long, z, n As Long
r = 4: Do Until Cells(r, 4) = "": s = Cells(r, 4): z = Split(s, "/")
            If UBound(z) Then
    Cells(r + 1, 1).Resize(UBound(z), 7).Insert: Cells(r, 4) = z(0)
For n = 1 To UBound(z): Cells(r + n, 1).Resize(1, 7).Value = _
Cells(r, 1).Resize(1, 7).Value: Cells(r + n, 4).Value = z(n)
Next n: r = r + n
            Else: r = r + 1: End If: n = 0: Loop
End Sub

[migos]

I totally get what was wrong with the code know I was resizing beyond the table size. Thank you so much xladept. I really appreciate it.

[xladept]

You're welcome As long as it's a table and we're inserting rows, I couldn't think of a way to implement the "End.(xlUp).Row" because the row count is in flux