Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
ID tematu: 64014 Skopiuj do schowka Makro, które zlicza ekstrema tygodnia w całym arkuszu
Autor Wiadomość
DamianG 
Starszy Forumowicz


Posty: 32
  Wysłany: 02-02-2019, 16:11   Makro, które zlicza ekstrema tygodnia w całym arkuszu

Cześć,
Mam dane takie jak w załączniku i chciałbym napisać makro:
- które liczy ile jest tygodni w całym arkuszu i wyświetla tę liczbę,
- które następnie pogrubia najwyższą i najniższą liczbę danego tygodnia,
- które wyświetla, ile najwyższych lub najniższych liczb wystąpiło w poniedziałek lub wtorek itd. Tzn. chcę określić jak często ekstremum danego tygodnia wystąpiło np. w poniedziałek lub w dowolny inny dzień tygodnia. Jak to zrobić?

ekstr.xlsx
Pobierz Plik ściągnięto 27 raz(y) 48.44 KB

ID posta: 361829 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 2624 razy
Posty: 8659
Wysłany: 02-02-2019, 16:39   

DamianG napisał/a:
ile jest tygodni w całym arkuszu i wyświetla tę liczbę
Ile jest tygodni między pierwszym a ostatnim wierszem zakresu, czy ile jest widocznych w tym zakresie tygodni. W tym przykładzie są akurat wszystkie tygodnie więc należy zwrócić 14. A co w przypadku gdyby np. tygodnia 40 nie było? Dalej 14 czy już 13?

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 361834 Skopiuj do schowka
 
 
DamianG 
Starszy Forumowicz


Posty: 32
Wysłany: 02-02-2019, 21:15   

Jeśli tygodnia 40 nie będzie to wtedy jest 13. Po prostu chodzi o to, by można było porównać ilość tygodni do tego jak często ekstremum występuje np. w poniedziałek.
ID posta: 361837 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Wersja: Win Office 2013
Pomógł: 278 razy
Posty: 1521
Wysłany: 04-02-2019, 11:35   

Dane są niespójne - dni nie odpowiadają datom kalendarzowym. Zakładając konwencję 5 dni roboczych w tygodniu - sprawdź: 25 sierpień ( to akurat uzupełniłem), wiersz 30-32 > :?: .

W załączeniu plik w którym starałem się to jakoś ogarnąć - ale jeżeli to ma być sztuka dla sztuki to nie widzę sensu robienia statystyk.

Info: kod tylko zaznacza MIn / Max (jeżeli błędnie - to z powodu j.w.).

Kod:
Option Explicit

Private Sub CommandButton1_Click()
Dim pocz As Integer, j As Integer, k As Integer
Dim i As Integer, d As Integer, ileTyg As Integer
Dim rng As Range, addMax As String, addMin As String

On Error Resume Next

Application.ScreenUpdating = False

d = Cells(Rows.Count, "A").End(xlUp).Row

'zakładając pełne "tygodnie" (tydzień = 5 dni):
ileTyg = DateDiff("w", Cells(2, 1), Cells(d, 1), vbMonday) + 1

'-----------------------------------------------------------
'wyznaczenie 1-szego poniedziałku - na razie niewykorzystane
i = 2
Do Until Weekday(Cells(i, 1).Value, 2) = 1
    i = i + 1
Loop
pocz = i
'-----------------------------------------------------------

For j = 1 To d Step 5
    Set rng = Range(Cells(j + 1, 2), Cells(j + 5, 3))
    addMax = mxAddr(rng)
    Range(addMax).Font.Bold = True
    addMin = mnAddr(rng)
    Range(addMin).Font.Bold = True
Next j

Application.ScreenUpdating = True

End Sub

Function mnAddr(prng As Range) As String
    Application.Volatile
    Dim minVal As Double, minAddr As String, c As Range
   
    minVal = prng.Cells(1).Value
    minAddr = prng.Cells(1).Address
    For Each c In prng
        If c.Value < minVal Then
            minVal = c.Value
            minAddr = c.Address
        End If
    Next c
    mnAddr = minAddr
End Function

Function mxAddr(prng As Range) As String
    Application.Volatile
    Dim maxVal As Double, maxAddr As String, c As Range
   
    maxVal = prng.Cells(1).Value
    maxAddr = prng.Cells(1).Address
    For Each c In prng
        If c.Value > maxVal Then
            maxVal = c.Value
            maxAddr = c.Address
        End If
    Next c
    mxAddr = maxAddr
End Function


Kopia ekstr.xlsm
Pobierz Plik ściągnięto 7 raz(y) 61.94 KB

_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
I dbajmy - proszę - o poprawną polszczyznę.
ID posta: 361909 Skopiuj do schowka
 
 
DamianG 
Starszy Forumowicz


Posty: 32
Wysłany: 04-02-2019, 16:39   

W arkuszu są dni 'handlowe' czyli dużo dat po prostu nie ma (np. święta). W arkuszu, który załączyłem są tylko 3 miesiące, w całym roku będzie brakować o wiele więcej dni. I to jest właśnie główny problem.
ID posta: 361935 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Wersja: Win Office 2013
Pomógł: 278 razy
Posty: 1521
Wysłany: 04-02-2019, 17:31   

Cytat:
W arkuszu są dni 'handlowe' czyli dużo dat po prostu nie ma (np. święta)



Bełkot językowy.Wątek usuwam.
.
_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
I dbajmy - proszę - o poprawną polszczyznę.
ID posta: 361939 Skopiuj do schowka
 
 
DamianG 
Starszy Forumowicz


Posty: 32
Wysłany: 04-02-2019, 20:14   

Dlaczego? Chciałem tylko rozwiać Twoje wątpliwości odnośnie 'niespójności danych'. Jeśli 25 sierpnia 2003 roku wypadło jakieś święto to nie ma tej daty w arkuszu. W tym arkuszu są tylko i wyłącznie dni handlowe/robocze. Dlaczego uważasz, że takie wytłumaczenie to bełkot?
ID posta: 361946 Skopiuj do schowka
 
 
kuma 
Excel Expert


Pomógł: 1178 razy
Posty: 3518
Wysłany: 05-02-2019, 00:42   

Przetestuj mój kod.
Ilość tygodni masz w G2.
W kol. od H2 (poniedziałek) liczba wskazująca ile max wartości wystąpiło w ten dzień, a w kol. 'I' odpowiednio liczba min wartości wystąpień w dany dzień. Kolejne dni tygodnia poniżej.
Kod:
Sub ZliczTygodnie()
    Dim a(), td
    Dim i As Integer, j As Integer, k As Integer, t As Integer, _
            dt As Integer, ldt As Integer, hr As Integer, lr As Integer
    Dim lv As Single, hv As Single
    Dim hd, ld, itm
    Dim d As Object, scol As Object
   
    Application.ScreenUpdating = False
    With Sheets("OHLC")
        a = .Range("A2:C" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1).Value
        .Range("A2:C" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1).Font.Bold = False
        .[G2].Resize(7, 3).ClearContents
        Set d = CreateObject("scripting.dictionary")
        Set scol = CreateObject("System.Collections.ArrayList")
        lv = 10 ^ 4:        t = 1
        For i = 1 To UBound(a)
            j = i + 1
            dt = Weekday(a(i, 1), vbMonday)
            If dt > ldt And i < UBound(a) Then
                ldt = dt
            Else
                d.Item(1 * hd(0)) = d.Item(1 * hd(0)) + 1
                If Not scol.Contains(1 * hd(0)) Then scol.Add 1 * hd(0)
                d.Item(10 * ld(0)) = d.Item(10 * ld(0)) + 1
                If Not scol.Contains(10 * ld(0)) Then scol.Add 10 * ld(0)
                .Cells(hr, 2).Font.Bold = True
                .Cells(lr, 3).Font.Bold = True
                lv = 10 ^ 4: hv = 0
                ldt = 0:        t = t + 1
            End If
            If a(i, 2) > hv Then
                hv = a(i, 2)
                hd = Split(Join(Array(dt, "|", a(i, 2))), "|")
                hr = i + 1
            End If
            If lv > a(i, 3) Then
                lv = a(i, 3)
                ld = Split(Join(Array(dt, "|", a(i, 3))), "|")
                lr = i + 1
            End If
        Next
        scol.Sort
        .[G2] = t - 1
        For Each itm In scol
            .Cells(IIf(itm < 6, itm + 1, 1 + itm / 10), IIf(itm < 6, "H", "I")) = d(itm)
        Next
    End With
    Set d = Nothing
    Set scol = Nothing
End Sub
Pozdrawiam.
ID posta: 361965 Skopiuj do schowka
 
 
apollo
ExcelSpec


Pomógł: 1230 razy
Posty: 4264
Wysłany: 05-02-2019, 00:58   

DamianG napisał/a:
Dlaczego? Chciałem tylko rozwiać Twoje wątpliwości odnośnie 'niespójności danych'. Jeśli 25 sierpnia 2003 roku wypadło jakieś święto to nie ma tej daty w arkuszu. W tym arkuszu są tylko i wyłącznie dni handlowe/robocze. Dlaczego uważasz, że takie wytłumaczenie to bełkot?

Bo tak uznał, niekoniecznie musi mieć rację. Lubi usunąć cudze posty a ma możliwość to usunął. I tyle.
ID posta: 361966 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Wersja: Win Office 2013
Pomógł: 278 razy
Posty: 1521
Wysłany: 05-02-2019, 10:26   

Pomyłka. Przepraszam. :-|
_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
I dbajmy - proszę - o poprawną polszczyznę.
ID posta: 361979 Skopiuj do schowka
 
 
DamianG 
Starszy Forumowicz


Posty: 32
Wysłany: 05-02-2019, 18:09   

kuma napisał/a:
Przetestuj mój kod.


Super, dzięki. Dokładnie o to chodziło. Ale jak spróbowałem uruchomić to makro dla większej ilości danych to wyskoczył błąd: 'Run-error 9 Subscription out of range'. Wiesz jak to poprawić?
ID posta: 362012 Skopiuj do schowka
 
 
kuma 
Excel Expert


Pomógł: 1178 razy
Posty: 3518
Wysłany: 05-02-2019, 23:52   

Nie podałeś, w którym miejscu. Domyślam się, że może to być związane z deklaracją zmiennej 'i'. Zmień deklarację zmiennej
z
Kod:
Dim i as Integer, ....
na
Kod:
Dim i as Long, ...
Pozdrawiam.
ID posta: 362043 Skopiuj do schowka
 
 
DamianG 
Starszy Forumowicz


Posty: 32
Wysłany: 06-02-2019, 16:46   

Niestety to nie pomaga. W załączeniu screen z błędem

error.png
Plik ściągnięto 12 raz(y) 79.53 KB

ID posta: 362078 Skopiuj do schowka
 
 
kuma 
Excel Expert


Pomógł: 1178 razy
Posty: 3518
Wysłany: 06-02-2019, 19:39   

Czy Twój arkusz nosi nazwę 'OHLC'?
Spróbuj zmienić nazwę
Kod:
With Sheets("OHLC")

na odpowiednią nazwę arkusza. Myślę, że jest inna.
Kod:
With Sheets("Odpowiednia_nazwa arkusza")
Pozdrawiam.
ID posta: 362086 Skopiuj do schowka
 
 
Waldek 
ExcelSpec


Pomógł: 121 razy
Posty: 579
Wysłany: 07-02-2019, 03:11   

Ja zaproponuję arkusz prawie bez makr. W kolumnie J (Nr tyg. unikat) jest tzw. funkcja użytkownika NrTyg, więc odmiana makra. Można ją zastąpić formułą wbudowaną. Początkowo chciałem zrobić formuły bez kolumn pomocniczych E, F, G, H ale mi się nie udało.

ekstr (2).xlsm
Pobierz Plik ściągnięto 8 raz(y) 26.01 KB

ID posta: 362104 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe