ikboy

Sub zz()
Dim arr, zr%, zc%, MyMemo, brr() As String
zr = [a1].CurrentRegion.Rows.Count
zc = [a1].CurrentRegion.Columns.Count
n = -1
arr = Range(Cells(2, 1), Cells(zr, zc))
For i = 1 To UBound(arr)
    MyMemo = Split(Application.Substitute(arr(i, 5), " ", ";"), ";")
    For j = 0 To UBound(MyMemo)
        PQ = Split(MyMemo(j), "*")
            n = n + 1: ReDim Preserve brr(5, n)
            For ii = 0 To 3
                brr(ii, n) = arr(i, ii + 1)
            Next
            brr(4, n) = PQ(0)
            If UBound(PQ) = 1 Then
                If PQ(1) > 1 Then
                    brr(5, n) = PQ(1)
                Else
                    brr(5, n) = 1
                End If
            Else
                brr(5, n) = 1
            End If
    Next
Next
[h2].Resize(n + 1, 6) = Application.Transpose(brr)
End Sub