Excel VBA Vyhledávání podle datumu

Programy pro práci v kanceláři (Word, Excel, Access…=>Office)

Moderátor: Mods_senior

hoty21993
nováček
Příspěvky: 1
Registrován: únor 18
Pohlaví: Muž
Stav:
Offline

Excel VBA Vyhledávání podle datumu

Příspěvekod hoty21993 » 19 úno 2018 17:46

Zdravím,

Mohli by jste mi poradit mám celkem obsáhlé makro, kde bych potřeboval vypisovat všechny buňky které jsou přidané ve stejný měsíc, jedná se pouze o sloupec "N" , kde je napsané datum kdy byla chyba přidána.
Takže bych potřeboval aby mě makro projelo celý seznam ve sloupci "N" a vypsalo mi na další list do určité buňky "X" kolik jich v každém měsíci bylo nalezeno.
Zajímá mě pouze měsíc ne den ani rok.
V příloze přikládám obrázky, aby jste měli lepší info:)
Mohl by mi s tím někdo pomoct?

https://ufile.io/zheu0

https://imgur.com/gtJnGPP

https://imgur.com/2eNOI7H


Díky moc:)

Martin

Reklama
cmuch
Level 4.5
Level 4.5
Příspěvky: 1544
Registrován: březen 11
Bydliště: Drsná Vysočina :D
Pohlaví: Muž
Stav:
Offline

Re: Excel VBA Vyhledávání podle datumu

Příspěvekod cmuch » 19 úno 2018 19:27

Zdravím,
třeba takto?

Kód: Vybrat vše

Sub WriteCountErr()
 Dim lastrow As Integer, i As Integer
 Dim MyDate, MyMonth

 With Sheets("OPEN")
    'posledni radek v sl.N
    lastrow = .Cells(.Cells.Rows.Count, "N").End(xlUp).Row
    'opakuj pro vsechny radky krom zahlaví
    For i = lastrow To 2 Step -1
        MyDate = .Cells(i, "N")
        MyMonth = Month(MyDate)
        'zapis kazdy mesic na radek
        Sheets("X").Cells(MyMonth, 1) = Sheets("X").Cells(MyMonth, 1) + 1
    Next i
 End With
End Sub

Uživatelský avatar
elninoslov
Level 2.5
Level 2.5
Příspěvky: 366
Registrován: červen 13
Pohlaví: Muž
Stav:
Offline

Re: Excel VBA Vyhledávání podle datumu

Příspěvekod elninoslov » 19 úno 2018 21:37

Na to stačí maticový vzorec (Ctrl+Shift+Enter). Do B6 na liste Error_graph_2017 vložte toto a rozkopírujte po M6.

Kód: Vybrat vše

=SUM((OPEN!$N$2:$N$1000<>"")*(MONTH(OPEN!$N$2:$N$1000)=COLUMN(A$1)))
=SUMA((OPEN!$N$2:$N$1000<>"")*(MĚSÍC(OPEN!$N$2:$N$1000)=SLOUPEC(A$1)))

Ale keď to chcete makrom, tak nie po jednej bunke, ale naraz cez pole:

Kód: Vybrat vše

Sub WriteCountErr()
Dim RowsCount As Long, i As Long, arrDate(), arrErrors(1 To 1, 1 To 12) As Long, MyMonth As Byte

  With Sheets("OPEN")
    RowsCount = .Cells(Rows.Count, 14).End(xlUp).Row - 1    'Počet řádků s daty v sl. N
   
    If RowsCount > 0 Then                                   'Pokračuj když nejaké data jsou
      ReDim arrDate(1 To RowsCount, 1 To 1)
      If RowsCount = 1 Then                                 'Načíst data do pole
        arrDate(1, 1) = .Cells(2, 14).Value2
      Else
        arrDate = .Cells(2, 14).Resize(RowsCount).Value2
      End If
     
      For i = 1 To RowsCount                                'Opakuj pro všechny data
        If Not IsEmpty(arrDate(i, 1)) Then                  'Když to není prázdná bunka
          MyMonth = Month(arrDate(i, 1))                    'Zjisti měsíc
          arrErrors(1, MyMonth) = arrErrors(1, MyMonth) + 1 'Pričti počet chyb do pole počtú chyb, podle indexu měsíce
        End If
      Next i
    End If
  End With
 
  Sheets("Error_graph_2017").Cells(6, 2).Resize(, 12) = arrErrors   'Zapiš počet chyb ve všech měsících najednou
End Sub


EDIT:
Keď teraz pozerám na to Vaše makro, pochybujem o jeho korektnej funkčnosti. Sú tam technické a logické nedostatky.
Napr.:
-Pri získavaní názvu aktuálneho a predošlého mesiaca v časti Case "12" máte Mesic = "DEC" a Mesic2 = "JAN". Správne má byť ale Mesic2 = "NOV". Každopádne sa to dá oveľa kratšie zapísať, napr.:

Kód: Vybrat vše

Dim arrMonths()
    arrMonths = Array("DEC", "JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC")
    Mesic = arrMonths(Month(Date))
    Mesic2 = arrMonths(Month(Date) - 1)

-Nepoužívať neustále .Activate a .Select. Namiesto toho použite napr.:

Kód: Vybrat vše

With Worksheets("Error_graph_2017")
  .Range("X3").Value = .Range("W3").Value
  ...
End With

a list nemusí byť vôbec aktívny.
-Odkladáte riadky 3,4,5,6,7,9,10. A riadok 8 nie ? Skráťte to na 1 riadok kódu namiesto 7 riadkov, napr.:

Kód: Vybrat vše

.Range("X3:X10").Value = .Range("W3:W10").Value

to isté pri

Kód: Vybrat vše

.Range("Y4:Y10").Value = .Range("W4:W10").Value

(tým riadkom 5 a 8 to asi vadiť nebude).
-Vyfarbujete oblasť "N12:Q21", ale v skutočnosti ju máte "N13:Q22".
-Nepoužívajte cyklus While a neustály .Select buniek na zistenie počtu. Použite napr. :

Kód: Vybrat vše

Pocet_chyb = WorksheetFunction.CountIf(Worksheets("OPEN").Columns(1), "<>") - 1

alebo

Kód: Vybrat vše

Pocet_chyb = Worksheets("OPEN").Cells(Rows.Count, 1).End(xlUp).Row - 1

-Pri počítaní poc_chyb_pred_rokem_2016_objevleden/poc_chyb_od_roku_2016_objevleden ... nepočítate s rokom 2017 ? Ak sa má zarátať rok 2017 k tým ktoré sú po roku 2016 (čo je logické), nemôže byť operátor

Kód: Vybrat vše

Right(Cells(radek, 4), 4) > 2017

ale musí byť

Kód: Vybrat vše

Right(Cells(radek, 4), 4) >= 2017

prípadne

Kód: Vybrat vše

Right(Cells(radek, 4), 4) > 2016

-Ako odlišujete "Červ" ako "Červenec" od "Červ" ako "Červen" ?
-Nepoužívajte 24 premenných na mesiace pred a po r. 2016. Použite pole napr.

Kód: Vybrat vše

Dim arrPole(1 to 2, 1 to 12) As Long

a nezapisujte po jednom (navyše ako som spomínal posunul ste všetky riadky, a zapisujete ich makrom na zlý riadok. Nemôžete len tak meniť rozloženie, keď máte viazané makro !):

Kód: Vybrat vše

Range("B7").Value = poc_chyb_pred_rokem_2016_objevleden
Range("B8").Value = poc_chyb_od_roku_2016_objevleden
...

ale zapíšte ich naraz

Kód: Vybrat vše

.Range("B8:M9").Value = arrPole

-Na počet riadkov/buniek nepoužívajte Integer, ale Long. Pozrite sa koľko má Excel od v. 2007 riadkov. Integer nestačí.
-Jednoduchšie by bolo nepoužívať "Leden 2016" ale použiť v bunkách normálny dátum 1.1.2016 a naformátovať ho vlastným formátom "mmmm yyyy" (v CZ je to "mmmm rrrr"), akurát že bude 1. písmenko malé. Potom ale zisťovanie mesiaca robíte jednoducho Month(bla bla), a nie škriabaním sa ľavou nohou za pravým uchom cez Left(Cells(radek, 5), 4) = "Červ"
...

Ďalej sa mi to už študovať ani nechce
...

Uživatelský avatar
elninoslov
Level 2.5
Level 2.5
Příspěvky: 366
Registrován: červen 13
Pohlaví: Muž
Stav:
Offline

Re: Excel VBA Vyhledávání podle datumu

Příspěvekod elninoslov » 20 úno 2018 12:19

Tak som sa pozrel na to bližšie. Zeleným je označené, čo som Vám zmenil a išlo by odstrániť. Len už nemám čas pozrieť na úplne posledný blok na to vyfarbenie tých pár buniek. Každopádne berte na vedomie, že som to napísal len tak z hlavy BEZ AKÉHOKOĽVEK SKÚŠANIA. Teda testujte si to na kópii súborov (to platí vlastne vždy) a prípadné chyby reportujte. Nechcelo sa mi to testovať, lebo mi to pripadá divné, bez bližšieho vysvetlenia. Skúste presne slovne v krokoch popísať čo sa má diať. Prípadne priložte aj ten druhý súbor, lebo to makro, čo tam máte je nešťastné...
Alebo si z toho zoberte len inšpirácie ...
Přílohy
eng_chyby---kopie úprava.xlsm
(340.71 KiB) Staženo 35 x


  • Mohlo by vás zajímat
    Odpovědi
    Zobrazení
    Poslední příspěvek
  • Google vyhledávání-reCaptcha Příloha(y)
    od ski1961 » 23 kvě 2023 16:58 » v Internet a internetové prohlížeče
    4
    1904
    od kecalek Zobrazit poslední příspěvek
    24 kvě 2023 14:59
  • Vyhledávání z adresní řádky - chyba (Chrome) Příloha(y)
    od pikaso.andreas » 23 říj 2023 14:34 » v Internet a internetové prohlížeče
    1
    2274
    od rhsCZ Zobrazit poslední příspěvek
    25 říj 2023 19:55
  • Excel a OneDrive
    od sginfo » 11 zář 2023 15:28 » v Kancelářské balíky
    16
    5984
    od mirekol Zobrazit poslední příspěvek
    20 říj 2023 08:31
  • excel-posun makra
    od actionboy » 12 bře 2024 18:59 » v Kancelářské balíky
    1
    259
    od Grimm Zobrazit poslední příspěvek
    12 bře 2024 21:43
  • Excel - problém se vzorci
    od honzzicek » 28 čer 2023 21:45 » v Kancelářské balíky
    2
    1632
    od honzzicek Zobrazit poslední příspěvek
    01 črc 2023 08:57

Zpět na “Kancelářské balíky”

Kdo je online

Uživatelé prohlížející si toto fórum: Žádní registrovaní uživatelé a 2 hosti