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

C

CastingDirector

New Member
Joined
Jun 10, 2014
Messages
46
Please consider helping me with this...
banghead.gif


Here is what I have on a sheet:
[TABLE="class: cms_table, width: 500"]
<tbody>[TR]
[TD]NAME (B)[/TD]
[TD]Date/time info (C)[/TD]
[TD]Agent (D)[/TD]
[TD][/TD]
[TD]Role/Notes (E)[/TD]
[/TR]
[TR]
[TD]Sam Smith[/TD]
[TD]4-29-2015 5:15 PM[/TD]
[TD]WM[/TD]
[TD][/TD]
[TD]Jimmy/Has Issues[/TD]
[/TR]
[TR]
[TD]Bud Light[/TD]
[TD]4-29 2015 3:12 PM[/TD]
[TD]CAA[/TD]
[TD][/TD]
[TD]Jimmy/No Travel[/TD]
[/TR]
[TR]
[TD]**** Wood[/TD]
[TD]4-23-2015 4:10 PM[/TD]
[TD]Front[/TD]
[TD][/TD]
[TD]Xavier/Not interested[/TD]
[/TR]
[TR]
[TD]Al Kida[/TD]
[TD]4-4-2015 2:00 PM[/TD]
[TD]Manager[/TD]
[TD][/TD]
[TD]Paul/Wife pregnant[/TD]
[/TR]
</tbody>[/TABLE]


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.
[TABLE="class: cms_table, width: 500"]
<tbody>[TR]
[TD]NAME (B)[/TD]
[TD]Date/Time Info(C)[/TD]
[TD]Agent(D)[/TD]
[TD][/TD]
[TD]Role/Notes(E)[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Jimmy[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Bud Light[/TD]
[TD]4-29-2015 4:10 PM[/TD]
[TD]CAA[/TD]
[TD][/TD]
[TD]No Travel[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Sam Smith[/TD]
[TD]4-29-2015 5:15 PM[/TD]
[TD]WM[/TD]
[TD][/TD]
[TD]Has Issues[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Paul[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Al Kida[/TD]
[TD]4-4-2015 2:00 PM[/TD]
[TD]Manager[/TD]
[TD][/TD]
[TD]Wife Pregnant[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Xavier[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]**** Wood[/TD]
[TD]4-23-15 4:10PM[/TD]
[TD]Front[/TD]
[TD][/TD]
[TD]Not Interested[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

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?
 

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.
Sort by date Sort by votes
Tested with the data you are showing but try this:

This is based onthe data already being sorted by column E

Code: 
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
 
Upvote 0
give this a shot.
Code: 
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
 
Upvote 0
This will work much better than my first post.
Code: 
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
 
Upvote 0
Soggy said:
Tested with the data you are showing but try this:

This is based onthe data already being sorted by column E

Code: 
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
Click to expand...

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?
 
Upvote 0
JLGWhiz said:
This will work much better than my first post.
Code: 
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
Click to expand...

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?
 
Upvote 0
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:

Code: 
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
 
Upvote 0
CastingDirector said:
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?
Click to expand...

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.
 
Upvote 0
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.
 
Upvote 0
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.
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question Question
Split and create sorted headings from first part of string
Replies
5
Views
823
CastingDirector
C
C
  • Question Question
Split and create headings...I am so stuck! Shout out to Rick Rothstein---you've helped me so much!
Replies
0
Views
424
CastingDirector
C

Forum statistics

Threads
1,223,248
Messages
6,171,021
Members
452,374
Latest member
keccles

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top