.. If Col2.Count > 5 Then...

Sub Buch1()
    Dim LastRow As Long, r As Long, mm As Integer
    Dim oRange As Range, k&, s$()
LastRow = Cells(Rows.Count, 2).End(xlUp).row
mm = 0
k = 1
    For r = 16 To LastRow
        mm = Range("B" & r).CurrentRegion.Rows.Count
            Select Case mm
            Case 4
            Set oRange = Range("B" & r).CurrentRegion
                Range("G" & r) = Left(oRange(1, 1).Value, 10)
                Range("H" & r) = oRange(2, 1).Value
                Range("I" & r) = oRange(3, 1).Value
                Range("J" & r) = oRange(4, 1).Value
                Range("K" & r) = oRange(4, 3).Value
                Range("L" & r) = oRange(4, 2).Value
                Range("L" & r).Replace What:=" ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
                Range("M" & r).FormulaR1C1 = "=RC[-1]/RC[-2]"
                ReDim s$(1 To 1, 1 To 7)
                s(1, 1) = Range("G" & r)
                s(1, 2) = Range("H" & r)
                s(1, 3) = Range("I" & r)
                s(1, 4) = Range("J" & r)
                s(1, 5) = Range("K" & r)
                s(1, 6) = Range("L" & r)
                s(1, 7) = Range("M" & r).Text
                k = k + 1
                Worksheets("Лист2").Cells(k, "A").Resize(1, 7) = s
            Case 7
            Case 10
            End Select
        r = r + mm
    Next r
End Sub