Can you help me split a cell and use first part as a new row heading?

[CastingDirector]

Please consider helping me with this...

Here is what I have on a sheet:

NAME (B)	Date/time info (C)	Agent (D)		Role/Notes (E)
Sam Smith	4-29-2015 5:15 PM	WM		Jimmy/Has Issues
Bud Light	4-29 2015 3:12 PM	CAA		Jimmy/No Travel
**** Wood	4-23-2015 4:10 PM	Front		Xavier/Not interested
Al Kida	4-4-2015 2:00 PM	Manager		Paul/Wife pregnant

<tbody>
</tbody>

So here is what I need in VBA sheet module... Please note: Column E (Role/Notes) should split, then first part is moved to make new row heading in bold and in alphabetical order.
The second part of string remains in the cell. Additional data is frequently copied from another sheet into this as well so it would need to accommodate new data over time.

NAME (B)	Date/Time Info(C)	Agent(D)		Role/Notes(E)
Jimmy
Bud Light	4-29-2015 4:10 PM	CAA		No Travel
Sam Smith	4-29-2015 5:15 PM	WM		Has Issues
Paul
Al Kida	4-4-2015 2:00 PM	Manager		Wife Pregnant
Xavier
**** Wood	4-23-15 4:10PM	Front		Not Interested

<tbody>
</tbody>

I am in the final leg of this 2 year journey to make this right (no kidding). Your help means everything to me. Is this do-able? Does it make sense?

 

[Soggy]

Tested with the data you are showing but try this:

This is based onthe data already being sorted by column E

Dim RoleT, RoleF As String
Dim LocT, LocF As Integer
Dim lnglstrw As Long

lnglstrw = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row

lngRwCnt = 2
RoleT = ""
RoleF = ""
Do While lngRwCnt < lnglstrw + 1

LocT = InStr(Range("E" & lngRwCnt).Value, "/")
RoleT = Left(Range("E" & lngRwCnt).Value, LocT - 1)
Range("e" & lngRwCnt).Value = Right(Range("E" & lngRwCnt).Value, Len(Range("E" & lngRwCnt).Value) - LocT)
If RoleT <> RoleF Then
RoleF = RoleT
Rows(lngRwCnt).Insert
Range("A" & lngRwCnt).Value = RoleF
lngRwCnt = lngRwCnt + 1
lnglstrw = lnglstrw + 1
End If
lngRwCnt = lngRwCnt + 1
Loop

 

[JLGWhiz]

give this a shot.

Sub reorg()
Dim sh As Worksheet, lr As Long, spl As Variant
Set sh = Sheets(1) 'Edit sheet name
lr = sh.Cells(Rows.Count, "E").End(xlUp).Row
    For i = lr To 2 Step -1
        spl = Split(sh.Cells(i, 5).Value, "/")
        sh.Rows(i).Insert
        sh.Range("A" & i) = Trim(spl(LBound(spl)))
        sh.Range("E" & i + 1) = Trim(spl(UBound(spl)))
    Next
End Sub

 

[JLGWhiz]

This will work much better than my first post.

Sub reorg()
Dim sh As Worksheet, lr As Long, spl As Variant, fn As Range, i As Long
Set sh = Sheets(1) 'Edit sheet name
lr = sh.Cells(Rows.Count, "E").End(xlUp).Row
    For i = lr To 2 Step -1
        spl = Split(sh.Cells(i, 5).Value, "/")
        If Application.CountIf(sh.Range("B:B"), Trim(spl(LBound(spl)))) > 0 Then
            Set fn = sh.Range("B:B").Find(Trim(spl(LBound(spl))), , xlValues, xlWhole)
                If Not fn Is Nothing Then
                    Rows(i).Copy
                    fn.Offset(1, 0).EntireRow.Insert
                    fn.Offset(1, 3) = Trim(spl(UBound(spl)))
                    Rows(i).Delete
                End If
        Else
            sh.Rows(i).Insert
                sh.Range("B" & i) = Trim(spl(LBound(spl)))
                sh.Range("E" & i + 1) = Trim(spl(UBound(spl)))
        End If
    Next
End Sub

 

[CastingDirector]

Tested with the data you are showing but try this:

This is based onthe data already being sorted by column E

Dim RoleT, RoleF As String
Dim LocT, LocF As Integer
Dim lnglstrw As Long

lnglstrw = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row

lngRwCnt = 2
RoleT = ""
RoleF = ""
Do While lngRwCnt < lnglstrw + 1

LocT = InStr(Range("E" & lngRwCnt).Value, "/")
RoleT = Left(Range("E" & lngRwCnt).Value, LocT - 1)
Range("e" & lngRwCnt).Value = Right(Range("E" & lngRwCnt).Value, Len(Range("E" & lngRwCnt).Value) - LocT)
If RoleT <> RoleF Then
RoleF = RoleT
Rows(lngRwCnt).Insert
Range("A" & lngRwCnt).Value = RoleF
lngRwCnt = lngRwCnt + 1
lnglstrw = lnglstrw + 1
End If
lngRwCnt = lngRwCnt + 1
Loop

Thanks so much for this. I am getting a "Object Variable or With Block variable not set" I am not sure how to correct...Thoughts?

 

[CastingDirector]

This will work much better than my first post.

Sub reorg()
Dim sh As Worksheet, lr As Long, spl As Variant, fn As Range, i As Long
Set sh = Sheets(1) 'Edit sheet name
lr = sh.Cells(Rows.Count, "E").End(xlUp).Row
    For i = lr To 2 Step -1
        spl = Split(sh.Cells(i, 5).Value, "/")
        If Application.CountIf(sh.Range("B:B"), Trim(spl(LBound(spl)))) > 0 Then
            Set fn = sh.Range("B:B").Find(Trim(spl(LBound(spl))), , xlValues, xlWhole)
                If Not fn Is Nothing Then
                    Rows(i).Copy
                    fn.Offset(1, 0).EntireRow.Insert
                    fn.Offset(1, 3) = Trim(spl(UBound(spl)))
                    Rows(i).Delete
                End If
        Else
            sh.Rows(i).Insert
                sh.Range("B" & i) = Trim(spl(LBound(spl)))
                sh.Range("E" & i + 1) = Trim(spl(UBound(spl)))
        End If
    Next
End Sub

Hi and thanks so much for this. I am getting "Sub Script Out of Range" message. "For i = lr To 2 Step -1" needed to change to "For i = lr To 7 Step -1" but still not working. Thoughts?

 

[Soggy]

Hi,

It might be I did not define the row count variable (lngrwcnt) it worked OK in mine but that might just be a version thing. Try this one:

Dim RoleT, RoleF As String
Dim LocT, LocF As Integer
Dim lnglstrw, lngrwcnt As Long

lnglstrw = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row

lngRwCnt = 2
RoleT = ""
RoleF = ""
Do While lngRwCnt < lnglstrw + 1

LocT = InStr(Range("E" & lngRwCnt).Value, "/")
RoleT = Left(Range("E" & lngRwCnt).Value, LocT - 1)
Range("e" & lngRwCnt).Value = Right(Range("E" & lngRwCnt).Value, Len(Range("E" & lngRwCnt).Value) - LocT)
If RoleT <> RoleF Then
RoleF = RoleT
Rows(lngRwCnt).Insert
Range("A" & lngRwCnt).Value = RoleF
lngRwCnt = lngRwCnt + 1
lnglstrw = lnglstrw + 1
End If
lngRwCnt = lngRwCnt + 1
Loop

 

[JLGWhiz]

Hi and thanks so much for this. I am getting "Sub Script Out of Range" message. "For i = lr To 2 Step -1" needed to change to "For i = lr To 7 Step -1" but still not working. Thoughts?

That is odd for that error message on that particular line of code, since there is no object for it to seek on that line. If you edited the code before running, be sure sheet references and spelling are correct. Also, some error messages are generated when cell A1 is blank and that can be fixed by simply putting an asterisk in the cell. The code ran without error for me while using the sample in the OP.

 

[JLGWhiz]

I have tried several ways to duplicate the "Subscript out of range" error and cannot do it. It still remains a mystery to me of why that line was highlighted.

 

[JLGWhiz]

The only way I could get the error message was to put the code into a sheet code module and run the code twice without resetting the rows. The code should be in the standard module 1, not the sheet code module.