Друзья немного сократить код VBA

Формулировка задачи:

Ребят, написал код. Но он слишком большой. очень много If. Как бы мне его сократить. Механика кода проста. Есть сводная таблица, он оттуда просматривает значения и суммирует их вставляя в определенные ячейки результат моего вычисления. Т.е он находит сначала 2011 и все что меньше, выдает сумму, потом по 2012 также и до 2016.

Sub syma()
Dim w As Worksheet
Dim s1, s2, s3, s4, s5, s6, x As Integer
Dim a, b, c, d, e, f, lr As String
a = "2012"
b = "2013"
d = "2014"
e = "2015"
f = "2016"
lr = Cells(Rows.Count, 1).End(xlUp).Row
Set w = ActiveWorkbook.Sheets("Г’3")
For x = 5 To lr
c = Cells(x, 1)
If (Left(c, 4) < a) Then
s1 = s1 + Cells(x, 2)
w.Cells(4, 3) = s1
End If
 
If (Left(c, 4) = a) Then
s2 = s2 + Cells(x, 2)
w.Cells(5, 3) = s2
End If
 
If (Left(c, 4) = b) Then
s3 = s3 + Cells(x, 2)
w.Cells(6, 3) = s3
End If
If (Left(c, 4) = d) Then
s4 = s4 + Cells(x, 2)
w.Cells(7, 3) = s4
End If
If (Left(c, 4) = e) Then
s5 = s5 + Cells(x, 2)
w.Cells(8, 3) = s5
End If
If (Left(c, 4) = f) Then
s6 = s6 + Cells(x, 2)
w.Cells(9, 3) = s6
End If
 
Next x
End Sub

Решение задачи: «Друзья немного сократить код VBA»

textual
                            Листинг программы 
                        

                            Option Explicit
 
Sub syma()
Dim w As Worksheet
Dim x As Integer
Dim a, b, c, d, e, f, lr As String
a = "2012"
b = "2013"
d = "2014"
e = "2015"
f = "2016"
lr = Cells(Rows.Count, 1).End(xlUp).Row - 1
Set w = ActiveWorkbook.Sheets("Т3")
w.Range(w.Cells(4, 3), w.Cells(9, 3)).ClearContents
w.Range(w.Cells(4, 5), w.Cells(9, 5)).ClearContents
w.Range(w.Cells(4, 7), w.Cells(9, 7)).ClearContents
For x = 5 To lr
c = Cells(x, 1)
Select Case Left(c, 4)
Case a: w.Cells(5, 3) = w.Cells(5, 3) + Cells(x, 2)
Case b: w.Cells(6, 3) = w.Cells(6, 3) + Cells(x, 2)
Case d: w.Cells(7, 3) = w.Cells(7, 3) + Cells(x, 2)
Case e: w.Cells(8, 3) = w.Cells(8, 3) + Cells(x, 2)
Case f: w.Cells(9, 3) = w.Cells(9, 3) + Cells(x, 2)
Case Else
w.Cells(4, 3) = w.Cells(4, 3) + Cells(x, 2)
w.Cells(4, 5) = w.Cells(4, 5) + Cells(x, 4)
w.Cells(4, 7) = w.Cells(4, 7) + Cells(x, 6)
 
End Select
Next x
End Sub
                        