I have a table 2 columns wide insert a column B and use text to columns to split column A into A and the new B but it keeps overwriting C with blanks.
start sample:
Level & Part Numbers Description
5 NAS1130-3L20D INSERT HCOIL 10/32 UNF .380L
5 NAS1130-3L20D INSERT HCOIL 10/32 UNF .380L
5 NAS1130-3L20D INSERT HCOIL 10/32 UNF .380L
Prepared to:
Level Part Numbers Description
5 NAS1130-3L20D INSERT HCOIL 10/32 UNF .380L
5 NAS1130-3L20D INSERT HCOIL 10/32 UNF .380L
5 NAS1130-3L20D INSERT HCOIL 10/32 UNF .380L
Text to col desire
Level Part Numbers Description
5 NAS1130-3L20D INSERT HCOIL 10/32 UNF .380L
5 NAS1130-3L20D INSERT HCOIL 10/32 UNF .380L
5 NAS1130-3L20D INSERT HCOIL 10/32 UNF .380L
Actual result:
Level Part Numbers Description
5 NAS1130-3L20D
5 NAS1130-3L20D
5 NAS1130-3L20D

Full code: 
Sub ListRep2STBoM()
Dim ListDoc As String
Dim LastRow As Long
Dim Partition As Long
Dim Entry As Range
Application.ScreenUpdating = False
MsgBox "Select BoM Tree data file"
ListDoc = Application.GetOpenFilename("Text Files (*.txt), *.txt")
    If ListDoc = "False" Then MsgBox "No file selected!": End
    
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & ListDoc, Destination:=ActiveSheet.Range("$A$1"))
        .Name = "ActiveSheetList"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 3
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With

LastRow = ActiveSheet.UsedRange.Rows.Count
With ActiveSheet.Range("A1:A" & LastRow)
    .Value = Evaluate("if(Sheet1!" & .Address & "<>"""",trim(Sheet1!" & .Address & "),"""")")
    .Replace What:=": ", Replacement:=":", Lookat:=xlPart
    .TextToColumns Destination:=ActiveSheet.Range("A1"), DataType:=xlDelimited, Other:=True, Otherchar:=":", FieldInfo:=Array(Array(0, 1), Array(2, 1)), TrailingMinusNumbers:=True
    ActiveSheet.Range("B1").Delete shift:=xlUp
    .Replace What:="Nomenclature", Replacement:="", Lookat:=xlWhole
    If LastRow > 8000 Then
        Partition = 2
        Do While Partition < LastRow
            ActiveSheet.Range(ActiveSheet.Cells(Partition, 1), ActiveSheet.Cells(Partition + 8000, 1)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
            Partition = Partition + 1000
        Loop
    Else
        .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End If
End With
ActiveSheet.Columns("B:B").Insert
LastRow = ActiveSheet.Cells(1, 1).End(xlDown).Row
ActiveSheet.Range("A1:A" & LastRow).TextToColumns Destination:=ActiveSheet.Range("A1"), DataType:=xlDelimited, Other:=True, Otherchar:=" ", FieldInfo:=Array(Array(0, 1), Array(2, 1)), TrailingMinusNumbers:=True
For i = 1 To LastRow
    If Cells(i, 2).Value = "" Then Exit For
    Cells(i, 4).Value = 1
    Do
        If Cells(i, 2).Value = Cells(i + 1, 2).Value Then
            Cells(i, 4).Value = Cells(i, 4).Value + 1
            Cells(i + 1, 2).EntireRow.Delete
        Else
            Exit Do
        End If
    Loop
Next i
ActiveSheet.Columns("A:D").AutoFit
Application.ScreenUpdating = True
End Sub
Area of concern: 
ActiveSheet.Range("A1:A" & LastRow).TextToColumns Destination:=ActiveSheet.Range("A1"), DataType:=xlDelimited, Other:=True, Otherchar:=" ", FieldInfo:=Array(Array(0, 1), Array(2, 1)), TrailingMinusNumbers:=True