Sub GLingeneer()
Dim arr(), I&, J&, N&, W&, iMonth
Dim arrWF(0 To 11) As Double, arrMonth()
Dim dicMonth As Object
On Error Resume Next
Application.ScreenUpdating = False
With ActiveSheet
    .Outline.ShowLevels RowLevels:=2
    arr = .Range("B5:C" & .Cells(.Rows.Count, "C").End(xlUp).Row).Value
    arrMonth = Array("Январь", "Февраль", "Март", "Апрель", _
                    "Май", "Июнь", "Июль", "Август", _
                    "Сентябрь", "Октябрь", "Ноябрь", "Декабрь")
    Set dicMonth = CreateObject("Scripting.Dictionary")
    For I = 0 To UBound(arrMonth): dicMonth(arrMonth(I)) = I + 1: Next
    ReDim arrNew(1 To UBound(arr, 1), 1 To 14)
    N = 1
    For I = 1 To UBound(arr)
        If arr(I, 2) <> Empty Then
            iMonth = Split(Trim(arr(I, 1)))
            If UBound(iMonth) > 0 Then
                If dicMonth.Exists(iMonth(0)) Then J = dicMonth(iMonth(0))
                If J <> Empty Then
                    arrNew(N, J) = arr(I, 2)
                    arrWF(W) = arr(I, 2)
                    W = W + 1
                End If
            End If
        End If
        If arr(I, 2) = Empty Or I = UBound(arr) Then
            For J = 1 To 12
                If arrNew(N, J) = Empty Then arrNew(N, J) = 0
            Next
            With Application.WorksheetFunction
                arrNew(N, 14) = .StDevP(arrWF) / .Average(arrWF)
            End With
            Erase arrWF: J = Empty: W = Empty: N = I + 1
        End If
    Next
    .Range("D5").Resize(UBound(arrNew, 1), UBound(arrNew, 2)) = arrNew
    .Outline.ShowLevels RowLevels:=1
End With
Application.ScreenUpdating = True
End Sub