Automatizujeme reporty: Ako dostať z textu PSČ a číslo domu

 

Najprv chcem poďakovať za námet, myslím si že je to často diskutovaný prípad v rámci reportov. Nebudem chodiť okolo horúcej kaše, vrhneme sa na prípad (Súbor s funkciami na stiahnutie dole):

Zadanie je jednoduché: z textu potrebujeme vrátiť PS4, Ulicu a Číslo domu.

Problém však nastáva vo forme toho textu. V realite nám možnosť Text To Columns nemusí postačovať, obzvlášť tak dostávame “ručne” naplnené tabuľky.

Začnem PSČ. Ak si pozrieme štruktúru PSČ, s istotou môžeme tvrdiť, že ak nájdeme v texte tri po sebe idúce znaky ako čísla, tak skoro s istotou sa nachádzame na PSČ. Tým pádom vytvoríme FOR cyklus, ktorý nájde takúto možnosť. potom stačí použiť hodnotu iteračného čísla z for cyklu ako začiatočné písmeno pri funkcii MID alebo ČÁST a máme PSČ (viď kód):

Function NajdiPSC(text As String)

Dim i As Integer

Const Cisla = "0123456789"

'Nájdem trojčíslie v texte
For i = 1 To Len(text)

    If InStr(Cisla, Mid(text, i, 1)) <> 0 And InStr(Cisla, Mid(text, i + 1, 1)) <> 0 And InStr(Cisla, Mid(text, i + 2, 1)) <> 0 Then
        'Vytrhnem z textu oblasť, začínajúca trojčíslím
        NajdiPSC = Mid(text, i, Len(text))
        Exit Function
    End If
       
Next i

End Function

Tak a máme PSČ, viď obrázok:

Teraz potrebujeme dostať číslo domu, čo bude trošku ťažší oriešok, no stručná metodika: nájdeme trojčíslie, ktoré bude prvá obmedzujúca podmienka pre FOR cyklus, teda i=1 až pozícia trojčíslia. V tomto obmedzení nájde prvé číslo, čím vznikne nové obmedzenie, teda i= poloha prvého čísla až po polohu trojčíslia. V tomto obmedzení budeme hľadať polohu prvého písmena. Následne použijeme funkciu MID alebo ČÁST, kde z textu vrátime časť od polohy prvého čísla až po polohu prvého písmenka, viď kód:

Function NajdiCisloDomu(text As String)

Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer

Const Cisla = "0123456789"

'Nájdem trojčíslie v texte
For i = 1 To Len(text)

    If InStr(Cisla, Mid(text, i, 1)) <> 0 And InStr(Cisla, Mid(text, i + 1, 1)) <> 0 And InStr(Cisla, Mid(text, i + 2, 1)) <> 0 Then
        j = i
        GoTo dalej1
    End If
       
Next i

'Nájdem prvé číslo v texte
dalej1:
For i = 1 To j - 1

    If InStr(Cisla, Mid(text, i, 1)) <> 0 Then
        k = i
        GoTo dalej2
    End If
Next i

'Nájdem prvé písmenko v rámci obmedzenia prvé číslo - trojčíslie
dalej2:
For i = k + 1 To j - 1
    If InStr(Cisla, Mid(text, i, 1)) = 0 Then
    l = i
    GoTo dalej3
    End If
Next i

dalej3:

'Ošetrím ak popisné číslo je jednociferné
If l - k = 0 Then
    l = 1
Else
    l = l - k
End If

'Ošetrím ak nenájdem číslo domu
If k = 0 Then
    NajdiCisloDomu = ""
Else
    NajdiCisloDomu = Mid(text, k, l)
End If

End Function

Výsledok vyzerá nasledovne (ulicu alebo povedzme doplnkový text už nie je problém vyselektovať):

Súbor s funkciami stiahnete kliknutím na obrázok. Nezabudnite na Facebook, stačí kliknúť na logo a v prípade dotazov a podobných problémov ako je tento s radosťou odpoviem

Automatizujeme reporty: automatické aktualizácie kurzu €

Určite ste sa už niekedy stretli s reportom, ktorý v sebe obsahoval Kč-y a €-á. Takýto report v sebe pravdepodobne obsahuje sheet s tabuľkou, obsahujúcou kurzy podľa dátumu, kedy bol report robený a dáte mi za pravdu ,že buď trávite niekoľko minút copy-paste-ním aktuálnych sadzieb z centrálnej banky alebo máte komplikovanú procedúru, ktorá stiahne celý .CSV súbor a vytiahne z neho hodnotu, ktorú momentálne potrebujete.

Čo tak zvoliť elegantnejší spôsob?

Ja som sa v rámci svojich reportov rozhodol obísť tieto procedúry a vytvoril som si funkciu s názvom =eukurz(“dátum”). Jej výhoda spočíva v jednoduchosti, stačí ak ju odkážete na bunku s dátumom a ona Vám vráti požadovaný kurz.

VBA riešenie vyzerá nasledovne:

Function EuKurz(datum As Date)
Dim Mena As String
Dim CNBfix
Dim SDatum As String
Dim CNBobjekt
Dim URL
Mena = "EUR"
CNBfix = TimeSerial(14, 30, 0)
Set CNBobjekt = CreateObject("MSXML2.XMLHTTP")
  
'Ošetríme možnosť, že dátum je z budúcna
If datum > Format(Now, "Short Date") Or datum = "0:00:00" Then
    EuKurz = " "
    Exit Function
End If
  
'ČNB aktualizuje kurzy po 14.30 - t.z. pred 14:30 vezmeme kurz z predch. dňa
If datum = Format(Now, "Short Date") Then
    If Time < CNBfix Then
        datum = datum - 1
    End If
End If
   
'Ak je dátum rovný Sobote alebo Nedeli, posunieme sa a použijeme kurz z najbližšieho piatku
If (Weekday(datum, vbMonday) > 5) Then
    datum = datum - Weekday(datum, vbMonday) + 5
End If
'SDatum pre odkazSDatum = Format(datum, "dd.mm.yyyy")
 
'adresa odkazu (ČNB)URL = "http://www.cnb.cz/miranda2/m2/cs/financni_trhy/devizovy_trh/kurzy_devizoveho_trhu/vybrane.txt?mena=" & Mena & "&od=" & SDatum & "&do=" & SDatum
CNBobjekt.Open "GET", URL, False
CNBobjekt.send

If (InStr(1, CNBobjekt.responseText, SDatum)) = 0 Then
    EuKurz = "-"
Else
    EuKurz = Mid(CNBobjekt.responseText, InStr(1, CNBobjekt.responseText, SDatum) + Len(SDatum) + 1, Len(CNBobjekt.responseText))
End If
'On error resume next v prípade, že používate iný než anglický Excel (aby výsledok nebol #HODNOTA!)On Error Resume NextEuKurz = CDbl(Replace(EuKurz, ",", "."))
EuKurz = CDbl(EuKurz)
Set CNBobjekt = Nothing

End Function

Nakoľko sa daný kód môže zdať trošku komplikovaný, je to spôsobené tzv. ošetrujúcimi podmienkami. Každopádne si hotovú funkciu môžete stiahnuť kliknutím na obrázok Download a nezabudnite na Facebook skupinu

Ako vymazať alebo obnoviť niektoré pomenované oblasti

 

V realite sa stáva, že človek dostane pod ruku report, ktorý prešiel mnohými firmami – oddeleniami. Takéto reporty sa zvyknú správať tak trochu netradične. Značné problémy môžu spôsobovať nefungujúce definované oblasti (Defined Names). Pokiaľ sa pokúšate vytvoriť alebo obnoviť niektoré výpočtové operácie a chcete ich zjednodušiť pomocou definovaných oblastí, takýto pohľad do Name Manager-a nebude príjemný:

Pre zbavenie a možné nadefinovanie nových pomenovaných oblastí som vytvoril nasledujúce makro:

Sub CleanDefNames()
    Dim DefName As Name
    Dim UB
   

'For-cyklus vymaže všetky definované oblasti + On Error preskočí nejasnosti Excelu
    On Error Resume Next
    For Each DefName In ThisWorkbook.Names
        DefName.Delete
    Next DefName
    On Error GoTo 0
   
   'Definujeme počet riadkov novej definovanej oblasti
    UB = Sheets("DATA").Cells(Rows.Count, 1).End(xlUp).Row
   
    'Ak je posledný riadok rovný 1, potom definovanú oblasť nemá zmysel robiť - je prázdna
    If UB = 1 Then
        MsgBox "Hodnoty pre pomenovanú oblasť neexistujú", vbCritical
        Exit Sub
    End If
   
    'Vytvorí sa nová definovaná oblasť s názvom POKUS
    ActiveWorkbook.Names.Add Name:="POKUS", RefersToR1C1:="=DATA!R2C1:R" & UB & "C1"
   
    End Sub

Ak spustíte danú procedúru, v prípade, že v liste DATA v prvom stĺpci nemáte žiadnu hodnotu, objaví sa Vám nasledujúce okno:

Toto okno len upozorňuje, že sa pomenovaná oblasť POKUS nevytvorila, lebo stĺpec v liste DATA bol prázdny. V konečnom dôsledku týmto makrom si môžete neustále (po vlastnej úprave) aktualizovať pomenované oblasti a tým pádom budete mať po každom prečistení “čerstvé” výpočty.

Mimochodom, pomocou danej procedúry schudol môj report o viac než 0.5 MB, čo nie je na škodu veci. Celý tento proces si môžete pozrieť na nasledujúcom videu:

 

Refresh–Defined Names

Nabudúce si pripravíme niečo “SPECIAL” …. máte sa načo tešiť a nezabúdajte na Facebook fun-page!