VBA: optimalizace, zrychlení funkcí

[d1amond]

Zdravím.

Mám následující problém. Jsou zadané dva datumy a den v týdnu (čísla 1-7, kde 1 = pondělí). Potřebuji spočítat počet dní mezi těmito datumy, které odpovídají danému dni. Viz ukázkový sešit v příloze.
Problém není s počtem dní, ale s výjimkami, které jsou na listu parametry. Jsou tam vyjmenované dny, které se mají přeskakovat.

Potřebuji zda by někdo měl nápad, jak funkce urychlit, protože to trvá dost dlouho. Nevím zda je rychlejší procházet seznam parametru pomocí While nebo použít Find. To je asi jediné, co mě napadlo.

Jsou to 3 fce, fnPocetDni, v té se spouští fnJeVolnyDen (prochází parametry a hledá shodu na datum) a také fnDenVTydnu (z datumu určí číslo dne v týdnu a porovná jej se zadaným).

Výsledek háže 0, ale i s tou je pomalé. Chybu 0 jsem zatím neodstranil, ale jde o běh, nikoliv správné číslo.

PocetDni.xls

(43 KiB) Staženo 34 x

Díky za nápady.

[Reklama]

[cmuch]

A co trochu jinak na to jít.

Kód: Vybrat vše

Sub PocetDni()

 Dim vyjimky As Range, Cll As Range, PocetDni As Long, dni As Long
 Dim dtDatumOd, dtDatumDo As Variant
 Dim bDen As Byte

 dtDatumOd = ThisWorkbook.Worksheets("data").Range("A2").Value2
 dtDatumDo = ThisWorkbook.Worksheets("data").Range("B2").Value2
 bDen = ThisWorkbook.Worksheets("data").Range("C2")

 Set vyjimky = Sheets("parametry").Range("A2:A" & Sheets("parametry").Cells(Rows.Count, "A").End(xlUp).Row)

 For PocetDni = dtDatumOd To dtDatumDo
 
  If bDen = Application.WorksheetFunction.Weekday(PocetDni, 2) Then

   For Each Cll In vyjimky

    If Cll.Value2 = PocetDni Then

      dni = dni - 1
    End If
   Next
   
   dni = dni + 1
   End If
 Next PocetDni
 
 Range("D2") = dni
End Sub

Edit..
To proč to trvá dlouho je způsobeno tím jak aktivuješ buňky na listu parametry. Pokud to předěláš tak to zrychlíš a povalí to jak blázen

[d1amond]

Díky, zkusím. Taky mě napadl FOR.

[lubo.]

Proč prolézáš oblast?

Snadno spočteš počet dnů mezi datumy (počet týdnů + korekce na začátku a na konci)

Stačí tedy spočíst počet vyjímek mezi daty
Můžeš prolézt oblast (je jich obvykle málo) nebo můžeš použít např. vzorec:

=SUMA(KDYŽ(KDYŽ((A2:A4>=data!A2)*(parametry!A2:A4<=data!B2);DENTÝDNE(parametry!A2:A4;2);-1)=data!C2;1;0))

V listu ve maticový, jinak application.evaluate, možná najdeš jednodušší, nechtělo se mi moc přemýšlet.

pak stačí dvě čísla odečíst.

Mimochodem, vzorcem to jde taky celkem snadno.

[d1amond]

Mohl bys to nějak blíž rozepsat? Worksheet.Evaluate jsem nikdy nepoužíval.

[cmuch]

Jukni tu http://excelplus.net/news.php?readmore=111

[d1amond]

Kód: Vybrat vše

Sub Pokus1()
Dim r, iPocet As Integer
Dim rng As Range
Dim Cell As Range
Dim dtDatum As Date
Dim dtDatumOd As Date
Dim dtDatumDo As Date
Dim wshParam As Worksheet
Dim wshData As Worksheet
Dim bDen As Byte

Set wshParam = Worksheets("parametry")
Set wshData = Worksheets("data")
bDen = wshData.Range("C2")
dtDatumOd = wshData.Range("A2")
dtDatumDo = wshData.Range("B2")

iPocet = 0
r = wshParam.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Worksheets(2).Range("A1:A" & r)

For dtDatum = dtDatumOd To dtDatumDo
If DatePart("w", dtDatum, vbMonday) = bDen Then
    For Each Cell In rng
        If Cell.Value = dtDatum Then
            GoTo Dalsi
        End If
    Next
iPocet = iPocet + 1
End If

Dalsi:
Next

Set wshParam = Nothing
Set rng = Nothing

Range("D2") = iPocet

End Sub

cmuch: trochu upravena tvoje procedura - jsem na 16ms, což už je slušné. Na cyklus pomocí Find to je stejně rychlé.

Díky

[lubo.]

Kód: Vybrat vše

Function fnPocetDni(DatumOd As Date, DatumDo As Date, bDen As Byte) As Integer
Dim Pocet As Integer
Dim dt As Date
Dim i As Long
Dim svatky As Variant
   
   Pocet = (DatumDo - DatumOd) / 7
   
   For dt = dtDatumOd + Pocet * 7 To dtDatumDo
   'zda vyhovuje cislo dne
      If CByte(DatePart("w", dt, vbMonday)) <> bDen Then
         Pocet = Pocet + 1
         Exit For
      End If
   Next dt
   
   svatky = ThisWorkbook.Worksheets("parametry").Range("a2:a4").Value
   For i = LBound(svatky, 1) To UBound(svatky, 1)
      'zda vyhovuje cislo dne
      dt = svatky(i, 1)
      If (dt >= DatumOd) And (dt <= DatumDo) Then
         If CByte(DatePart("w", dt, vbMonday)) = bDen Then Pocet = Pocet - 1
      End If
   Next i
   
   fnPocetDni = Pocet
End Function