• Úvod
• Excel návod
• Excel šablony
• Nástěnka
• Mobility
• Tipy na výlet
• Galerie
• Fórum

Příspěvky uživatele

To ani omylom nepôjde takto ako to máte. Uvedomte si, že počas doby pred uložením súboru, môže prísť k zmene mnohých čísel v mnohých riadkoch, ďalej v kombináciách s "a" či bez "a" v susednom stĺpci, a navyše môže dôjsť k navráteniu pôvodnej hodnoty, ktorá bola pri poslednom otvorení súboru (alebo pri poslednom odoslaní mailu) a to znovu v kombinácii s/bez "a".

Teda Vy si musíte ukladať napr. na skrytý list, všetky pôvodné hodnoty (kópia celých stĺpcov A:B) a k nim všetky vykonané zmeny za celú počítanú dobu. To následne nejakým spôsobom vyhodnocovať v Workbook_BeforeSave. A tým vyhodnocovaním nemyslím odoslanie všetkého zo skrytého listu, ale iba toho čo sa zmenilo voči počiatočným dátam (teda ak sa aj hodnota zmenila 10x, ale v rozhodný okamžik je rovnaká ako na začiatku, tak sa považuje alebo nepovažuje za zmenenú ???). Ďalej napr. ak sa hodnota zmení 10x, má byť na ňu 10x upozornenie, alebo len raz ?

Technicko-logických komplikácií je tam fakt veľa.

Skúste jeden z týchto spôsobov:
Function NajdiLink(Artikel As String) As String
Dim httpRequest As New WinHttpRequest, oHTML As New HTMLDocument

Const URL$ = "https://www.sportisimo.sk/vyhladavanie/?hladany-vyraz="

With httpRequest
.Open "GET", URL & Artikel, False
.send 'Získanie HTML kódu
oHTML.body.innerHTML = .responseText 'Načítanie štruktúry stránky
On Error Resume Next
NajdiLink = oHTML.getElementsByClassName("Product_box")(0).getElementsByTagName("h3")(0).getElementsByTagName("a")(0).href 'Získanie odkazu na produkt
End With
End Function

Sub Hromadne()
Dim Linky() As String, Artikle(), R As Long, i As Long
Dim httpRequest As New WinHttpRequest, oHTML As New HTMLDocument

Const URL$ = "https://www.sportisimo.sk/vyhladavanie/?hladany-vyraz="

With ThisWorkbook.ActiveSheet
R = .Cells(Rows.Count, 1).End(xlUp).Row - 1
If R = 0 Then MsgBox "Žiadne artikle", vbExclamation: Exit Sub
If R = 1 Then 'Načítanie artiklov
ReDim Artikle(1 To 1, 1 To 1): Artikle(1, 1) = .Cells(2, 1).Value
Else
Artikle = .Cells(2, 1).Resize(R).Value
End If
ReDim Linky(1 To R, 1 To 1)


For i = 1 To R
With httpRequest
.Open "GET", URL & Artikle(i, 1), False
.send 'Získanie HTML kódu
oHTML.body.innerHTML = .responseText 'Načítanie štruktúry stránky
On Error Resume Next
Linky(i, 1) = oHTML.getElementsByClassName("Product_box")(0).getElementsByTagName("h3")(0).getElementsByTagName("a")(0).href 'Získanie odkazu na produkt
On Error GoTo 0
End With
Next i

.Cells(2, 2).Resize(R).Value = Linky 'Zápis výsledných linkov
End With
End Sub

Vyskúšajte toto. Ale skúšajte to výhradne na kópii časti súborov. Ak by to nerobilo, to čo chcete, aby ste nemal potom guláš.
Sub Presun()
Dim Data(), R As Long, i As Long, OldSoubor As String, Interpret As String, Pisen As String, Casti() As String, Cesta As String, Vysledek() As String, FSO As Object

Const ROZDEL$ = " - "
Const BEZ_INTERPRETA$ = "Bez interpreta"
Const NEEXISTUJE$ = "Neexistuje"
Const NEPRESUNUTELNY$ = "Nepřesunutelný"
Const OK$ = "OK"

With ThisWorkbook.ActiveSheet
R = .Cells(Rows.Count, 1).End(xlUp).Row - 1
If R = 0 Then MsgBox "Žádné řádky dat.", vbExclamation: Exit Sub
Data = .Cells(2, 1).Resize(R, 3).Value
ReDim Vysledek(1 To R, 1 To 3)

Set FSO = CreateObject("Scripting.FileSystemObject")

For i = 1 To R
Casti = Split(Data(i, 2), ROZDEL)
If UBound(Casti) > 0 Then
Interpret = Casti(0)
Pisen = Casti(1)
Vysledek(i, 1) = Interpret
Else
Interpret = BEZ_INTERPRETA
Pisen = Casti(0)
End If

Vysledek(i, 2) = Pisen
Cesta = Data(i, 1) & Interpret & "\"
OldSoubor = Data(i, 1) & Data(i, 2) & "." & Data(i, 3)

If Len(Dir(OldSoubor, vbNormal)) = 0 Then
Vysledek(i, 3) = NEEXISTUJE
Else
If Len(Dir(Cesta, vbDirectory)) = 0 Then MkDir Cesta

On Error Resume Next
FSO.MoveFile OldSoubor, Cesta & Data(i, 2) & "." & Data(i, 3)
Vysledek(i, 3) = IIf(Err.Number <> 0, NEPRESUNUTELNY, OK)
On Error GoTo 0
End If
Next i

.Cells(2, 4).Resize(R, 3).Value = Vysledek
End With
End Sub

Určite sa jedná na oboch PC o XLSX súbory ? Nie sú na tom druhom náhodou XLS alebo XLSM súbory ? Ak áno potom, musí byť maska "*.xls*" a nie "*.xlsx".

PS: Používajte deklarovanie premenných.

Sub pokus()
Dim FldrPicker As FileDialog, myPath As String, myFile As String

Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker) 'Retrieve Target Folder Path From User

With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
myPath = .SelectedItems(1)
myPath = myPath & IIf(Right$(myPath, 1) <> "\", "\", "")
End With

myFile = Dir(myPath & "*.xls*", vbNormal) 'Target Path with Ending Extention

'Loop through each Excel file in folder
Do While myFile <> ""

'*** opakující se práce s každým souborem
ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = myFile

myFile = Dir() 'Get next file name
Loop
End Sub

Uveďte už konečne tie vzorce na výpočet, či položka patrí alebo nepatrí do zoznamu pre daný riadok. Som zvedavý ako chcete dosiahnuť výpočtami podľa nejakých podmienok to, čo máte teraz v D:D (pl. kódy-text).

To čo chcete je skutočne podivné, neviem to urobiť Exceláckym spôsobom, tak ak by som to potreboval ja, tak by som si pomohol takýmto makrom:
Sub DoplnVzorec()
Dim V(), R As Long, stlpRef As Integer, stlpDopln As Integer, rngDopln As Range, i As Long, VRiadok As Long

Const VZOREC$ = "=A#+B#" 'Vzorec na doplnenie - # je náhrada čísla riadku

stlpRef = 1 'V ktorom stĺpci je referenčný počet riadkov
stlpDopln = 3 'V ktorom stĺpci sa bude dopĺňať

With ThisWorkbook.ActiveSheet
R = .Cells(Rows.Count, stlpRef).End(xlUp).Row - 1 'Zisti počet dátových riadkov
If R = 0 Then Exit Sub

With .Cells(2, stlpDopln).Resize(R)
If R = 1 Then 'Načítaj vzorce zo stĺpca do poľa pre dopĺňanie.
ReDim V(1 To 1, 1 To 1): V(1, 1) = .Formula 'To aby ostali prípadné vzorce zachované
Else 'Ak sú to maticové fungovať to nebude !!!
V() = .Formula
End If

For i = 1 To R 'Prejdi všetky riadky
If LenB(V(i, 1)) = 0 Then 'Ak je prázdna (0 dĺžka vzorca)
If VRiadok = 0 Then 'Ak ešte nebolo dopĺňané, nastav riadok vo vzorci na aktuálne skúmaný
VRiadok = i + 1
Else
VRiadok = VRiadok + 1 'Inak zvýš počítadlo riadku v dopĺňanom vzorci
End If
V(i, 1) = Replace(VZOREC, "#", VRiadok) 'Uprav riadok vo vzorci, a ulož do poľa vzorcov
End If
Next i

.Formula = V 'Zapíš naspäť do stĺpca pole s doplnenými vzorcami
End With
End With
End Sub

Overenie dát príjme reťazec zadaných hodnôt, iba ak ho tam Vy napíšete. Nie keď ten reťazec je počítaný vzorcom. Nedá sa použiť ani nejaké virtuálne maticové pole počítané vzorcom. Vzorcom sa dá odkazovať iba na bunky.

Univerzálny vzorec pre nepreddefinovaný počet listov s neznámymi názvami je problematický. Niektoré vzorce nemôžete použiť v Overení, preto treba použiť Definované názvy, ale tam zase musí byť odkaz na konkrétny list. Na odstránenie tohoto som použil INDIRECT ...

Teraz je to teda urobené tak, že každý list bude mať (napr. skryté) svoje vlastné výpočty. Tu to máte aj s vyfarbovaním nevalidných hodnôt (ktoré ľahko nastanú pri zmene podmienok ovplyvňujúcich výberový zoznam) cez Podmienené formátovanie. Je jedno koľko si nasekáte listov, len musia vzniknúť buď kopírovaním zo šablóny (čistého listu bez dát, s plnou funkcionalitou), alebo duplikovaním vyplnených listov.

Je to už takto pochopiteľné a akceptovateľné?

Som teraz len na mobile. Ten "neznámy názov" je GET.WORKBOOK, slúži na získanie zoznamu listov. Bohužiaľ funguje len v xlsm. Zapíšte do tabuľky zoznamu listov manuálne názvy listov. Malo by to fungovať. Preverím to prípadne až doma. Neviem, čo je v tej poslednej prílohe, ale ak tam nieje presne spôsob vypočtu položiek vzhľadom ku každému listu, tak je to bezpredmetné. Treba uviesť, či ma každý list svoje výpočty, a počet listov nieje pevny (spomínaná duplikácia listov), tak to bude problém.

Priložte príklad v prílohe (príloha sem pôjde vložiť, iba ak sa zaregistrujete).

Každý riadok každého listu má samostatne počítaný zoznam s podmieneným formátom na upozornenie na chybu.

Takto ako by ste to chcel, funkcie v Exceli nefungujú. Nemôžete si poskladať reťazec parametrov, a ten reťazec vložiť ako počítanú hodnotu do vzorca, nech si ho preberie. On potrebuje už samotné parametre, nie reťazec parametrov.

Každopádne, ak by ste nepotreboval to pridané meno, tak by ste mohol použiť Kontingenčnú tabuľku, ktorá je presne na to určená.

Ale keďže požadujete pridať občas nejaké meno, tak proste použite vzorec, ktorý máte na spočítanie podľa obyvateľov domu, ten Vám funguje, a pripočítajte k nemu ešte raz rovnaký vzorec, ale parameter bude to pridané meno. Ale to je stále maticové.

Ďalej je možné tento vzorec (2 vzorce medzi ktorými je "+") vložiť do Definovaného názvu. A potom do listu vkladáte už nematicový Definovaný názov. A basta.

ALE! Prečo teda nemáte v tých dátach jasne identifikovaný Dom. Ak by ste tam mali Dum1, Dum2,... Tak zrátate dom, a je šumák, či tam teda býva (je v zozname), ale tam býval (nieje v zozname).

Mne to chybu nedáva. To neznamená, že je makro správne (nevhodnosť postupu akým makro pracuje teraz neriešim). Priložte prílohu s reálnym príkladom. Citlivé dáta zmente a zredukujte. Ale nemente formáty ani umiestnenia ani názvy listov a pod.

Skúste to viac objasniť. Ja som vôbec nepochopil, prečo chcete prevádzať oblasť s podmienkami pre súčet, na reťazec napodobujúci reťazec vzorca. To tak nefunguje. Ak máte nejaký text v jednej bunke, a chcete zrátať iba hodnoty v bunkách C, pri ktorých v B je časť daného textu (iba časť!), tak maticový vzorec a FIND/NAJÍT. Ale to by ste musel popisovať Vašu situáciu presne opačne ako ju popisujete. Takto to nedáva zmysel.
Maticový vzorec bez zmyslu (Ctrl+Shift+Enter):
=SUM(IF(NOT(ISERROR(FIND(CHAR(34)&B6:B13&CHAR(34);CHAR(34)&TEXTJOIN(CHAR(34);TRUE;B2:B4)&CHAR(34))));C6:C13))

=SUMA(KDYŽ(NE(JE.CHYBHODN(NAJÍT(ZNAK(34)&B6:B13&ZNAK(34);ZNAK(34)&TEXTJOIN(ZNAK(34);PRAVDA;B2:B4)&ZNAK(34))));C6:C13))

Čo chcete robiť s tým makrom "Odemknout" (pôvodný názov "Makro1") ?
To označovanie B12 po každej zmene je nevhodné pri vpisovaní viac nových riadkov - skáče Vám kurzor inde, ako chcete písať.
Mali ste tam obrovské množstvo riadkov a stĺpcov, preto to bol taký veľký súbor.
Premýšľam, či by nebolo vhodnejšie použiť samostatné objekty Tabuľka (ListObject). Celý ten spôsob je taký divný a náchylný k chybe.

Všetko som pozmenil, prezrite...

Makrom sa to samozrejme dá, ale ak by to bolo možné použil by som radšej filter. Tu je príklad makra, maže a posúva samozrejme aj riadky v JK. Nič zatiaľ nezoraďuje, lebo neviem na základe čoho, iba ich súka pod seba.
Sub VymazHodnoty()
Dim JK(), BK(), V(), VJK(), R As Long, i As Long, VR As Long, y As Byte

With ThisWorkbook.ActiveSheet
R = .Cells(Rows.Count, "B").End(xlUp).Row
If R = 1 Then
ReDim JK(1 To 1, 1 To 1): JK = .Cells(1, "JK").Value
Else
JK = .Cells(1, "JK").Resize(R).Value
End If

BK = .Cells(1, "B").Resize(R, 10).Value
ReDim V(1 To R, 1 To 10)
ReDim VJK(1 To R, 1 To 1)

For i = 1 To R
If StrComp(JK(i, 1), "ano", vbTextCompare) <> 0 Then
VR = VR + 1
For y = 1 To 10
V(VR, y) = BK(i, y)
Next y
VJK(VR, 1) = JK(i, 1)
End If
Next i

.Cells(1, "B").Resize(R, 10).Value = V
.Cells(1, "JK").Resize(R).Value = VJK
End With

End Sub

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse