Sub NewMacros()
    Dim iRow&, LastRow&
    Dim iIndex&, sValue$
    Dim i&
    With ActiveSheet
        LastRow = .Cells(.Rows.Count, 5).End(xlUp).Row
        For iRow = 5 To LastRow
            iIndex = 0: sValue = VBA.Trim$(.Cells(iRow, 4).Value)
            If Len(VBA.Trim$(.Cells(iRow, 5).Value)) > 0 Then
                For i = 1 To Len(sValue)
                    If IsNumeric(Mid(sValue, i, 1)) And Mid(sValue, i, 1) <> " " Then
                        iIndex = iIndex * 10 + CInt(Mid(sValue, i, 1))
                    Else: Exit For: End If
                Next i
                If iIndex = 0 Then iIndex = 1
                .Cells(iRow, 17) = VBA.Trim$(Replace(sValue, CStr(iIndex), ""))
                .Cells(iRow, 18) = iIndex * .Cells(iRow, 5)
            End If
        Next iRow
    End With
End Sub

Sub tt()
    c_ = 4
    r0_ = 5
    n_ = Cells(Rows.Count, c_).End(3).Row - r0_ + 1
    If n_ < 1 Then Exit Sub
    ar = Cells(r0_, c_).Resize(n_, 2)
    On Error Resume Next
    For i = 1 To n_
        If IsNumeric(ar(i, 2)) And ar(i, 2) > 0 Then
            ar(i, 1) = Trim(ar(i, 1))
            If CByte(Left(ar(i, 1), 1)) Then
                For j = 1 To Len(ar(i, 1))
                    If Not IsNumeric(Left(ar(i, 1), j)) Then
                        ar(i, 2) = ar(i, 2) * Left(ar(i, 1), j - 1)
                        ar(i, 1) = Mid(ar(i, 1), j)
                        Exit For
                    End If
                Next j
            End If
        End If
    Next i
    Cells(r0_, c_).Resize(n_, 2) = ar
End Sub

ar(i, 2) = ar(i, 2) * Left(ar(i, 1), j - 1)
ar(i, 1) = Mid(ar(i, 1), j)

dim i&