upravena verze bez funkce LastRow, nazev listu je na zacatku subrutiny v promenne List

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, List As String
  ' zadat nazev listu!
  List = "list1"
  ' definice prohledavaneho bloku
  Set ZacBloku = Worksheets(List).Range("b7")
  ' definice bunky pro ulozeni vysledku souctu za sloupec b7:bxx
  Set Soucet = ZacBloku.Offset(-4, 0)
  ' ofset pro dalsi sloupce (E7:Exx, H7:Hxx,...)
  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 = Worksheets(List).Cells(Rows.Count, 2 + (ofs * i)).End(xlUp).Row
    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 = Worksheets(List).Cells(Rows.Count, 3 + (ofs * i)).End(xlUp).Row
    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