Příspěvky uživatele

Príloha žiadna. Ani riadiaci súbor, ani dátový súbor, ani štruktúra zložky, ani podrobnosti o umiestnení ostatných dát v zošitoch, ani počte listov. Dokonca ani to uvedené makro nieje celé.

Makro nijako neskúšam, lebo vytvárať si preň prostredie nebudem. Tak len na pohľad:

"v určené složce i podsložkách (zkrátka sběr dat)" - Nevidím síce celé makro, ale o tom pochybujem. To musí byť rekurzívna metóda, aby prešla všetky zložky a ich podzložky atď, a tu navyše nekontroluje ani hlavnú zložku.

LR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("A3:P3" & LR).EntireRow.Copy
To je zle! Veď do LR sa uloží posledný vyplnený riadok v A:A dolovaného listu. Tak napr. 10. Ale kopírovaná oblasť bude A3:P310 - vďaka tej napísanej 3-ojke. O možnom nevyplnenom údaji v stĺpci A:A hovoríte v suvislosti s týmto dolovaným listom, alebo s nasledujúcim riadkom ? :

wbMain.Sheets(ws.Name).Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Lebo tento riadok na prvý pohľad robí tú Vašu "chybu". Nemôžete skúmať ...End(xlUp)... pri každom prechode v stĺpci A:A, lebo môže byť nevyplnený. Namiesto toho si nadefinujte premennú
Dim RiadokZapisu As Long
ale kde a ako ju použiť záleží na celej koncepcii makra, ktoré nevidíme. Napr. môže byť potreba globálna premenná v prípade miltiprocedurálneho makra, alebo lokálna ak je to len 1 procedúra. V nej napr. predpokladajme, že má združená tabuľka hlavičku.

Ďalej čítajte počet riadkov podľa použitej oblasti (neberie ohľad iba na stĺpec A:A, ale tiež záleží na usporiadaní dolovaných dát, ktoré nevidíme)
UsedRange.Rows.Count + 1
a teda namiesto
wbMain.Sheets(ws.Name).Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
dajte napr. (odbrucha bez skúšania !)
RiadokZapisu = wbMain.Sheets(ws.Name).UsedRange.Rows.Count + 1
wbMain.Sheets(ws.Name).Range("A" & RiadokZapisu).PasteSpecial xlPasteValues

Každopádne ak sa jedná o zber dát, tak rozhodne nieje na mieste robiť Copy Paste s formátmi buniek a pod, ale stačí iba hodnoty čítať - to bude rýchlejšie. Ďalej by som to asi robil poľom a zapisoval naraz, nie po jednom - opäť urýchlenie.

Každopádne na takéto všelijaké dolovanie dát je vhodný PowerQuery, ktorý by Vám tu možno aj niektorí borci pomohli urobiť, ale bez príkladových súborov určo nie ...
...

S tým sa dá ihruškať ...

Skúste ešte úplne vynechať Copy.
Sub vlozeniNOVEHOkomentare()
'
' Makro1 Makro
'

Dim R As Long

Application.ScreenUpdating = False

R = ActiveCell.Row + 1

With Sheets("Zápis KDS")
.Cells(R, 1).Insert
With .Cells(R, 1).Resize(, 9)
.Value = Sheets("KD (pomoc)").Range("A5:I5").Value
.Cells(1, 5).Select
.Resize(, 7).Borders.Weight = xlHairline
.Cells(1, 1).NumberFormat = "@""-"""
.Cells(1, 2).NumberFormat = "0"
.Cells(1, 4).NumberFormat = "d/m/yy;@"
.Cells(1, 7).NumberFormat = "dd/mm/yy"
Union(.Cells(1, 3), .Cells(1, 5).Resize(, 2), .Cells(1, 8).Resize(, 2)).NumberFormat = "General"
End With
End With

Application.ScreenUpdating = True

'Calculate
End Sub

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

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje