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

Příspěvky uživatele

Skúste vymeniť to makro za iné.

Sub vlozeniNOVEHOkomentare()
'
' Makro1 Makro
'

Dim R As Long

Application.ScreenUpdating = False

Sheets("KD (pomoc)").Rows(5).Copy
R = ActiveCell.Row + 1

With Sheets("Zápis KDS")
.Cells(R, 1).Insert Shift:=xlDown
With .Cells(R, 1).Resize(, 9)
.Value = .Value
.Cells(1, 5).Select
End With
End With

Application.ScreenUpdating = True

Calculate
End Sub

A myslím, že volanie metódy Calculate tam nieje potrebné.

Po doplnení sviatkov do Vašeho súboru to normálne funguje ...

Alindros dostal navrhnuté riešenie v duplicitnej téme.

Inak tú istú tému ste založil 2.6.2019 a potom túto 10.6.2019. To sa nerobí !

Tak skúste objekt Tabuľka a Rýchly filter založený na vzorci s COUNTIFS v pomocnom stĺpci.

Prípadne
=COUNTIF($A2:$C2;">"&$E2)=3
kde $E2 je odkaz na bunku, ktorá obsahuje limitný dátum.

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).

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse