Zrychleni spociva v tom. ze budou scitany pouze hodnoty z neprazdnych bunek ve sloupcich (t.j. nebude se prochazet radek 7 - 1000) , vlozeni hlavicek je to nejmensi. Pokud je v nasledujici procedure nepotrebujes, vloz znak "'" (apostrof) na zacatky radku s vkladanim hlavicek (v procedure oznaceno).

Option Explicit

Sub Scitat()
' deklarace promennych
  Dim ZacBloku As Range, Blok As Range, Soucet As Range, Sum As Single
  Dim c As Range, i As Integer, ofs As Integer, PoslRadek As Long
  ' definice prohledavaneho bloku
  Set ZacBloku = Worksheets("list1").Range("b7")
  ' definice bunky pro ulozeni vysledku souctu za sloupec b7:b1000
  Set Soucet = ZacBloku.Offset(-4, 0)
  ' ofset pro dalsi sloupce (E7:E1000, H7:H1000,...)
  ofs = 3
  ' vykonna smycka projde vsechny sloupce pocinaje bunkou b7,c7 (e7,f7; h7,i7;...) az
  ' po posledni neprazdnou bunku ve sloupci
  For i = 0 To 51  ' pocet sloupcu
    '************ radky mezi "***" lze vypustit, dle potreby vloz "'" (apostrof) na zacatky radku *****
    ' vlozeni hlavicky do a2 (d2,g2,...)
    Soucet.Offset(-1, (ofs * i) - 1).Value = "Týždeò: " & i + 1
    ' vlozeni hlavicky do a3 (d3,g3,...) pro prijmy
    Soucet.Offset(0, (ofs * i) - 1).Value = "Príjmy:"
    ' vlozeni hlavicky do a4 (d4,g4,...) pro vydani
    Soucet.Offset(1, (ofs * i) - 1).Value = "Vydavky:"
    '********************************************************************************************
    ' hledani ve sloupci prijmu b7:bxx (e7:exx, h7:hxx,...)
    ' vynulovani promenne pro ulozeni mezisouctu prijmy
    Sum = 0
    ' nalezeni posledni neprazdne bunky ve sloupci b7:bxx (e7:exx, h7:hxx,...)
    PoslRadek = LastRow("list1", ofs * i)
    If PoslRadek > 6 Then
    Set Blok = ZacBloku.Resize(PoslRadek - 6, 1).Offset(0, ofs * i)
      For Each c In Blok.Cells
        ' testovani bunky ve sloupci prijmu b7:bxx (e7:exx, h7:hxx,...)
        If IsNumeric(c.Value) And _
          c.Font.Color = 0 Then Sum = Sum + c.Value  ' je cislo a cerna, pricist
      Next c
    End If
    ' vlozeni souctu do bunky b3 (e3, h3,...) pro prijmy
    Soucet.Offset(0, ofs * i).Value = Sum
    '***
    ' hledani ve sloupci vydani c7:cxx (f7:fxx, i7:ixx,...)
    ' vynulovani promenne pro ulozeni mezisouctu vydani
    Sum = 0
    ' nalezeni posledni neprazdne bunky ve sloupci c7:cxx (f7:fxx, i7:ixx,...)
    PoslRadek = LastRow("list1", (ofs * i) + 1)
    If PoslRadek > 6 Then
      Set Blok = ZacBloku.Resize(PoslRadek - 6, 1).Offset(0, (ofs * i) + 1)
      For Each c In Blok.Cells
        ' testovani bunky ve sloupci vydani c7:cxx (f7:fxx, i7:ixx,...)
        If IsNumeric(c.Value) And _
          c.Font.Color = 0 Then Sum = Sum + c.Value  ' je cislo a cerna, pricist
      Next c
    End If
    ' vlozeni souctu do bunky b4 (e4, h4,...) pro vydani
    Soucet.Offset(1, ofs * i).Value = Sum
  Next i
End Sub