súčet v excel-i

Ahoj, ako toto zopakujem 52 krát, s tým, že výsledky budú v "F3" a F4", "I3" a "I4"...:

Sub SumBlack()
    c3 = 0
    cerna = 0
    For n = 7 To 1000
        barva = Range("b" & n).Font.Color
        hodnota = Range("b" & n)
        If Not IsNumeric(hodnota) Then hodnota = 0
        If barva = cerna Then c3 = c3 + hodnota
    Next
    Range("c4") = c4
     c4 = 0
    cerna = 0
    For n = 7 To 1000
        barva = Range("c" & n).Font.Color
        hodnota = Range("c" & n)
        If Not IsNumeric(hodnota) Then hodnota = 0
        If barva = cerna Then c4 = c4 + hodnota
    Next
    Range("c4") = c4
End Sub

V Exceli si môžeš definovať vo VBA vlastnú funkciu, ktorá sa dá potom používať priamo vo vzorci rovnako ako štandardné funkcie: Create your own worksheet functions

Stále si nenapísal, na základe čoho sa farbia jednotlivé bunky. Je to na základe podmieneného formátovania, alebo to niekto musí ručne nastavovať? Ak je to ten druhý prípad, tak si rozmysli, či to nechceš zmeniť - hlavne v prípade, že ten súbor nepoužívaš len ty sám.

Rozumim-li dobre pozadavku, tak zde je trochu ucesana procedura scitajici hodnoty ze sloupcu B7:B1000 (E7:E1000, H7:H1000,...) az 52 krat a ukladajici soucty do bunek dle barvy fontu - cerna do C3 a cervena do C4 (F3:F4, I3:I4,...).

Option Explicit

Sub Scitat()
  Dim Blok As Range, c As Range, Soucet As Range, i As Integer, ofs As Integer
  Set Soucet = Worksheets("list1").Range("c3")
  Set Blok = Worksheets("list1").Range("b7:b1000")
  ofs = 3  ' ofset pro dalsi sloupce
  For i = 0 To 51  ' pocet sloupcu
    Soucet.Offset(0, ofs * i).Value = 0
    Soucet.Offset(1, ofs * i).Value = 0
    For Each c In Blok.Offset(0, ofs * i).Cells
      If IsNumeric(c.Value) Then
        If c.Font.Color = 0 Then Soucet.Offset(0, ofs * i).Value = Soucet.Offset(0, ofs * i).Value + c.Value  ' cerna
        If c.Font.Color = 255 Then Soucet.Offset(1, ofs * i).Value = Soucet.Offset(1, ofs * i).Value + c.Value  ' cervena
      End If
    Next c
  Next i
End Sub

Doplnuji:
Barva je brana pro zakladni barvu fontu, pokud by bylo potreba rozlisovat podle barvy nastavene podminenym formatem, pak je nutno pouzit tytez podminky do procedury a misto c.Font.Color pouzit c.Value=podminka!

asi som to zle vysvetlil,
v "B3" potrebujem sčítať hodnotu "čiernych (automatická farba)" čísel zo stĺpca "B7-B1000" a v "B4" zas hodnotu "čiernych" čísel zo stĺpca "C7-C1000" - toto všetko opakovať 52 krát. (Cash-flow, čierne písmo - už uskutočnené, červené písmo - plánované, stĺpec B - príjmy za 1 týždeň, stĺpec C - výdavky za 1 týždeň...)
A poprosím Ťa aj krátke vysvetlenie k riadkom, nech to aj pochopím, nie odpíšem.
Vďaka

Tady je upravena procedura:

Option Explicit

Sub Scitat()
' deklarace promennych
  Dim Blok As Range, Soucet As Range, SumPrijmy As Single, SumVydani As Single
  Dim c As Range, i As Integer, ofs As Integer
  ' definice prohledavaneho bloku
  Set Blok = Worksheets("list1").Range("b7:b1000")
  ' definice bunky pro ulozeni vysledku souctu za sloupec b7:b1000
  Set Soucet = Blok.Offset(-4, 0).Resize(1, 1)
  ' ofset pro dalsi sloupce (E7:E1000, H7:H1000,...)
  ofs = 3
  ' vykonna smycka projde vsechny sloupce
  For i = 0 To 51  ' pocet sloupcu
    ' vynulovani promennych pro ulozeni mezisouctu
    SumPrijmy = 0
    SumVydani = 0
    For Each c In Blok.Offset(0, ofs * i).Cells
      ' testovani bunky ve sloupci prijmu b7:b1000 (e7:e1000, h7:h1000,...)
      If IsNumeric(c.Value) And _
      c.Font.Color = 0 Then SumPrijmy = SumPrijmy + c.Value  ' je cislo a cerna, pricist
      ' testovani bunky ve sloupci vydani c7:c1000 (f7:f1000, i7:i1000,...), ma offset(0,1) oproti sloupci b(..)
          If IsNumeric(c.Offset(0, 1).Value) And _
      c.Offset(0, 1).Font.Color = 0 Then SumVydani = SumVydani + c.Offset(0, 1).Value  ' je cislo a cerna, pricist
        Next c
        ' 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 souctu do bunky b3 (e3, h3,...) pro prijmy
        Soucet.Offset(0, ofs * i).Value = SumPrijmy
        ' vlozeni hlavicky do a4 (d4,g4,...) pro vydani
        Soucet.Offset(1, (ofs * i) - 1).Value = "Vydavky:"
        ' vlozeni souctu do bunky b4 (e4, h4,...) pro vydani
        Soucet.Offset(1, ofs * i).Value = SumVydani
      Next i
    End Sub

Pokud splnuje pozadovane, tak upravim pro zrychleni behu.

funguje to perfektne, niečo som odtiaľ vyhodil - aby to zbytočne nevytváralo hlavičky (som myslel kôli zrýchleniu prepočtu), takže, ak sa to dá ešte nejako upraviť, tak Ťa poprosím. Ale už aj tak je to OK.

Option Explicit

Sub Scitat()
' deklarace promennych
  Dim Blok As Range, Soucet As Range, SumPrijmy As Single, SumVydani As Single
  Dim c As Range, i As Integer, ofs As Integer
  ' definice prohledavaneho bloku
  Set Blok = Worksheets("Makro").Range("b7:b1000")
  ' definice bunky pro ulozeni vysledku souctu za sloupec b7:b1000
  Set Soucet = Blok.Offset(-4, 0).Resize(1, 1)
  ' ofset pro dalsi sloupce (E7:E1000, H7:H1000,...)
  ofs = 3
  ' vykonna smycka projde vsechny sloupce
  For i = 0 To 51  ' pocet sloupcu
    ' vynulovani promennych pro ulozeni mezisouctu
    SumPrijmy = 0
    SumVydani = 0
    For Each c In Blok.Offset(0, ofs * i).Cells
      ' testovani bunky ve sloupci prijmu b7:b1000 (e7:e1000, h7:h1000,...)
      If IsNumeric(c.Value) And _
      c.Font.Color = 0 Then SumPrijmy = SumPrijmy + c.Value  ' je cislo a cerna, pricist
      ' testovani bunky ve sloupci vydani c7:c1000 (f7:f1000, i7:i1000,...), ma offset(0,1) oproti sloupci b(..)
          If IsNumeric(c.Offset(0, 1).Value) And _
      c.Offset(0, 1).Font.Color = 0 Then SumVydani = SumVydani + c.Offset(0, 1).Value  ' je cislo a cerna, pricist
        Next c
        ' vlozeni souctu do bunky b3 (e3, h3,...) pro prijmy
        Soucet.Offset(0, ofs * i).Value = SumPrijmy
        ' vlozeni souctu do bunky b4 (e4, h4,...) pro vydani
        Soucet.Offset(1, ofs * i).Value = SumVydani
      Next i
    End Sub

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

potrebna funkce LastRow je v dalsim prispevku, nebot je omezena delka prispevku

Pokracovani k predchozimu prispevku, pripoj za proceduru Scitat:

Function LastRow(L As String, ofs As Integer)
  Dim PosBunka As Range
  ' nastaveni na posledni radek listu ve sloupci
  Set PosBunka = Worksheets(L).Range("B:B").Offset(0, ofs).Cells(Range("B:B").Offset(0, ofs).Cells.Count)
  If IsEmpty(PosBunka) Then Set PosBunka = PosBunka.End(xlUp)
  If IsEmpty(PosBunka) Then  ' bunka na 1. radku  je take prazdna
    LastRow = 0
  Else
    LastRow = PosBunka.Row
  End If
End Function

S odstupem casu lze pozadovane resit bez makra a to vyuzitim maleho triku.
V bloku bunek B1:B1000 (C1:C1000) nastavit barvu fontu na automaticku a nastavit format bunek na cislo, pro zaporna cisla vybrat barvu cervena bez znamenka. Planovane prijmy (vydani) vkladat jako zaporne cislo, ktere bude zobrazeno jako cervene pismo bez znamenka.
Pro soucet v B3 pouzit vzorec: =SUMIF(B7:B1000;">0") a obdobne pro B4:=SUMIF(C7:C1000;">0")

Toto zopakovat pro dalsich 51 tydnu.

Pozn: poradna vlozila nekam jinam, nez jsem zamyslel

vyhadzuje mi to chybu v riadku:

PoslRadek = LastRow("Makro", ofs * i)

a je zvýraznené "LastRow"

Pro zjisteni duvodu chyby uved i chybove hlaseni, takhle byt na dalku, tezko zjistim pricinu.
Jen pro overeni, mas doinstalovanu funkci LastRow?
Predavas spravny nazev listu?
Zkusils krokovat proceduru (Editor VBA: Nastroje>View>LocalsWindow, kurzor mysi na proceduru a krokovat tlacitkem F8)?
Pouzivas jakou verzi Excelu?

Ďakujem Ti, teraz to už funguje super

psal jsem uz vcera, ale nejak se odpoved zasmodrchala mezi starsi, takze ji opakuji:

Pozadovane lze resit i bez makra a to vyuzitim maleho triku.
V bloku bunek B1:B1000 (C1:C1000) nastavit barvu fontu na automaticku a nastavit format bunek na cislo, pro zaporna cisla vybrat barvu cervena bez znamenka. Planovane prijmy (vydani) vkladat jako zaporne cislo, ktere bude zobrazeno jako cervene pismo bez znamenka.
Pro soucet v B3 pouzit vzorec: =SUMIF(B7:B1000;">0") a obdobne pro B4:=SUMIF(C7:C1000;">0")

Toto zopakovat pro dalsich 51 tydnu.

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

som tu chvilu nebol, ale vdaka, je to ok a prijemne sviatky