Sub СуммаЗаказов()
    Dim arr As Variant
    Dim y As Long
    With ActiveSheet
        y = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
        arr = .Range(.Cells(1, 1), .Cells(y, 10))
    End With
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim s As String
    Dim i As Long
    Dim d As Double
    For y = 1 To UBound(arr, 1)
        s = arr(y, 2)
        If Left(s, Len("Заказ ")) = "Заказ " Then
            s = Mid(s, Len("Заказ ") + 1, Len(s))
            i = InStr(s, " ")
            If i = 0 Then i = Len(s) + 1
            s = Mid(s, 1, i - 1)
            d = 0
            On Error Resume Next
            d = CDbl(Replace(arr(y - 1, 5), "К оплате ", ""))
            On Error GoTo 0
            dic.Item(s) = dic.Item(s) + d
        End If
    Next
    If dic.Count > 0 Then
        With Workbooks.Add(1).Sheets(1)
            .Cells(1, 1).Resize(dic.Count) = Application.Transpose(dic.keys())
            .Cells(1, 2).Resize(dic.Count) = Application.Transpose(dic.Items())
        End With
    End If
End Sub