Substrings from String

Hi all,

I'm trying to break down a string and put parts into designated cells using the following
code. I'm not sure what's causing the problem, but the substring results are not correct.

Sub BOMINSERT_HEADERS()
Dim OutPL As Worksheet
Dim SText As String
  Sheets("BOM_INSERT").Activate
  SText = Cells(2, "B").Value

 Set OutPL = Sheets("BOM")
   OutPL.Cells(3, "C") = SText
  ' OutPL.Cells(6, "C") = SText
  ' OutPL.Cells(7, "C") = SText
  ' OutPL.Cells(8, "C") = SText
  ' OutPL.Cells(9, "C") = SText
 
 
 
  Sheets("BOM").Activate
 Cells(6, "C") = WorksheetFunction.Substitute(Cells(3, "C"), "\", "~", 3)
 Cells(6, "C") = Right(Cells(6, "C"), InStr(1, Cells(6, "C"), "~") - 1)
 'Cells(7, "C") = WorksheetFunction.Substitute(Cells(7, "C"), "\", "~", 3)
 Cells(9, "C") = Right(Cells(6, "C"), InStr(1, Cells(6, "C"), "\"))
 Cells(8, "C") = WorksheetFunction.Substitute(Cells(8, "C"), "\", "~", 3)
 Cells(8, "C").Value = Right(Cells(8, "C"), InStr(1, Cells(8, "C").Value, "~") - 1)
  'Cells(6, "C") = WorksheetFunction.Substitute(Cells(3, "C"), "\", "~", 3)
 Cells(6, "C") = Left(Cells(6, "C"), InStr(1, Cells(6, "C"), "\") - 1)
   'OutPL.Cells(9, "C").Value = OutPL.Cells(7, "C").Value
' Cells(9, "C") = WorksheetFunction.Substitute(Cells(9, "C"), "\", "~", 1)
 'Cells(9, "C").Value = Left(Cells(8, "C"), InStr(1, Cells(8, "C"), "\") - 1)
  'Cells(9, "C").Value = Right(Cells(9, "C"), InStr(1, Cells(9, "C"), "\") - 1)
End Sub

Attached also is an example booklet. I've given an example of a 2nd string possiblity
that I'd like to have broken down if possible.

Any help getting this working is appreciated.

Thanks

BDB