Příspěvky uživatele
< návrat zpět
Príklady...
EDIT: Aktualizácia prílohy 12.9.2019 12:02
Ja keď si tu na skúšobných dátach urobím aj prehľady, tak či tak mi to kopíruje správne aj s prehľadmi s označenými bunkami, všetko. Musí byť zádrhel v tých Vašich súboroch, môžete mi jeden poslať neverejne na mail?
Ak ide len o to označenie či nascrolovanie, dá sa pridať jeden riadok
Application.Goto .Cells(1, 1), True
za riadkom
If Not rngMazat Is Nothing Then rngMazat.ClearContents 'Vymazanie hodnôt stĺpcov
Ak ide o zlé kopírovanie (rozmiestnenie a pod) musím vidieť reálny súbor.
Ach áno, samozrejme. Pretože, to som postoval iba upravenú procedúru CheckExists, vychádzajúcu z postu (5.9.2019 12:39). Rovnako ako aj ďalšie 2 úpravy (5.9.2019 14:45) vychádzajú z pôvodného postu (5.9.2019 12:39). V ňom je malá pomocná procedúra AddColor, ktorá je v ďalších upravených postoch nemenná. A zaujímavé, že po takej dobe a toľkých mojich úpravách zisťujem, že ste ich ani netestoval, lebo by Vám predsa tá AddColor chýbala aj v ostatných návrhoch. A načo sa tu potom snažím?
Slúži na pridanie bunky k ostatným zafarbovaným, aby sa nefarbilo po jednej, čo je pomalé, ale všetky naraz.
PS: Túto procedúrku nepotrebuje len môj posledný návrh, lebo ten nič nefarbí, vracia True/False.
No asi tomu stále nerozumiem, ale uvidíme...:
Private Sub btnZnovu_Click()
btnZnovu.BackColor = &H8000000F
Range("B1:B10").Formula = "=TODAY()+A1"
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Zmena As Range
Set Zmena = Intersect(Range("A1:A10"), Target)
If Not Zmena Is Nothing Then
btnZnovu.BackColor = vbGreen
Zmena.Offset(0, 1).ClearContents
Set Zmena = Nothing
End If
End Sub
Hodnoty do A vkladá užívateľ alebo makro ?
JE PODSTATNÉ čo je to za operáciu! Robí niečo so stĺpcom A a B? Vypína EnableEvents ? ...
B môže užívateľ alebo iné makro meniť nezávisle na A?
Ak A mení užívateľ, tak za zmenu sa považuje akákoľvek zmena vyvolaná pomocou udalosti listu Worksheet_Change ? Teda aj zmena hodnoty na rovnakú hodnotu? Alebo iba zmena na inú hodnotu ako tam bola? To je zásadný rozdiel v spracovaní, lebo druhý variant vyžaduje odkladanie starých hodnôt do skrytého listu.
atď....
veľmi slabý popis
No príloha má 1KB, takže je nefunkčná. Skúste ešte raz.
EDIT: Inak stačí asi iba toto:
=FIND(TEXT(B3;"dd.mm");"01.01,06.01,"&TEXT(DOLLAR(("4/"&YEAR(B3))/7+MOD(19*MOD(YEAR(B3);19)-7;30)*14%;)*7-8;"dd.mm,")&TEXT(DOLLAR(("4/"&YEAR(B3))/7+MOD(19*MOD(YEAR(B3);19)-7;30)*14%;)*7-5;"dd.mm,")&"01.05,08.05,05.07,29.08,01.09,15.09,01.11,17.11,24.12,25.12,26.12")
=NAJÍT(HODNOTA.NA.TEXT(B3;"dd.mm");"01.01,06.01,"&HODNOTA.NA.TEXT(KČ(("4/"&ROK(B3))/7+MOD(19*MOD(ROK(B3);19)-7;30)*14%;)*7-8;"dd.mm,")&HODNOTA.NA.TEXT(KČ(("4/"&ROK(B3))/7+MOD(19*MOD(ROK(B3);19)-7;30)*14%;)*7-5;"dd.mm,")&"01.05,08.05,05.07,29.08,01.09,15.09,01.11,17.11,24.12,25.12,26.12")
Toto je navrhnuté pre to, ak nechcete žiadne skryté pomocné stĺpce, ale Vy tam už máte mesiace skryté, takže by ste mohol mať kľudne aj tie sviatky. Každopádne nezabudnite, že pri úprave PF musíte stáť na B3.
Prečo stále tvrdošijne trváte na FSO? Ten na to vôbec nieje vhodný, lebo by ste musel cyklom kontrolovať pri každom volaní všetky súbory v adresári po jednom. Čo je pomalé, hlavne pri viacnásobnom volaní z viacerých buniek. Použite obdobu Dir z príkladu, čo som Vám urobil minule presne na mieru. Tu máte jej úpravu na True/False.
Function FileExists(full_path As String)
Dim V, Pos As Integer, tmp() As String, Nazov As String
If full_path <> "" Then
tmp = Split(full_path, Application.PathSeparator)
Nazov = tmp(UBound(tmp))
Pos = InStrRev(Nazov, ".")
FileExists = Len(Dir(Left$(full_path, Len(full_path) - IIf(Pos = 0, 0, Len(Nazov) - Pos - 1)) & "*")) > 0
End If
End Function
Toto reaguje plne dynamicky, pridávanie hlavných kategórií aj podkategórií, premenovanie. Netreba udržiavať Definované názvy podľa kategórií. Nastavené Podmienené formátovanie pre overenie správnej voľby.
Proste sa to dá robiť mnohými spôsobmi...
Tak vzorcom vylúčte víkendy a basta. Upravil som len prvé 2 tbl.
A) To preto, že ste si nevšimol, že používam kódové meno listu. Je nezávislé na názve listu na jeho ušku. Ale môžete používať aj to namiesto wsSeznam dáte Worksheets("Seznam")
B) Neviem, či rozumiem. Vy chcete mať tlačítka v niekoľkých stĺpcoch a kopírovať list, ktorého meno je uvedené vedľa tlačítka vľavo ? V tom prípade iba upravíte začiatok hlavného makra. Viď príloha.
No a samozrejme, keď ste si vybral nejnevhodnejší variant, s potrebou úprav volacích makier, tak si pridaním tlačítok musíte ako som minule popísal urobiť zmeny (vytvoriť kópiu makra, priradiť správne makro správnemu tlačítku, pomenovať ...)
Možno by pre Vás bolo vhodnejšie, ak by ste mal názov listu rovno na tlačítku, a vo volacích procedúrach jednotlivých tlačítok by bolo napevno namiesto Application.Caller zadané meno listu. Potom samozrejme aj maličká úprava jednej premennej v hlavnom makre.
Začiatok makra by potom vyzeral
Sub ExportList(JmenoListu As String, Vzorce As String, Mazat As String)
Dim NewWB As Workbook, Radku As Long, Posun As Long, SloupceVzorcu() As String, SloupceMazat() As String, i As Integer, rngMazat As Range
If ListExist(JmenoListu) Then 'Kontrola existencie listu, pre prípad nesprávneho zápisu v stĺpci A
...
a volacie makrá
Sub Export1() 'Tlačítko 1
ExportList "AAA", "E,G", "L,M"
End Sub
a obdobne
PS: Zošit obsahoval 3308 nefunkčných Definovaných názvov!
Ešte som urobil úpravu, aby v prípade, že nebude uvedená prípona a zároveň nadradený adresár bude obsahovať bodku, nepovažoval aj časť názvu adresára za príponu. Teraz je fuk, či máte názvy s príponou, bez, aj či je v názve adresára bodka.
Sub CheckExists()
Dim rngRed As Range, rngGreen As Range, ARE As Range, Oblast As Range, Cell As Range, V, Pos As Integer, tmp() As String, Nazov As String, Separator As String
Set Oblast = Intersect(ActiveSheet.UsedRange, Selection)
If Oblast Is Nothing Then MsgBox "Žiadne data": Exit Sub
Separator = Application.PathSeparator
For Each ARE In Oblast.Areas
For Each Cell In ARE.Cells
V = Cell.Value
If Not IsEmpty(V) Then
tmp = Split(V, Separator)
Nazov = tmp(UBound(tmp))
Pos = InStrRev(Nazov, ".")
If Len(Dir(Left$(V, Len(V) - IIf(Pos = 0, 0, Len(Nazov) - Pos - 1)) & "*")) = 0 Then AddColor rngRed, Cell Else AddColor rngGreen, Cell
End If
Next Cell
Next ARE
If Not rngRed Is Nothing Then rngRed.Font.Color = vbRed
If Not rngGreen Is Nothing Then rngGreen.Font.Color = vbGreen
End Sub
Urobil som Vám tam radšej aj kompletný popis makra.
No netuším čo s tým robíte, akú oblasť testujete, ale u mňa 100 súborov urobí za mrknutie oka. Rôzne druhy súborov XLSX, XLSM, MP3, ISO, JPG, TXT, TIB, FLAC, CSV, MP4, ... niekoľko vnorení adresárov, pomiešané 4 HDD ...
čo máte ako testovanú oblasť ? Snáď nie celý stĺpec ?
EDIT: Určite označujete celý stĺpec. Veď to je milión riadkov. Tak si namiesto Vašeho Selection dajte nejakú oblasť, alebo to aspoň najskôr vypodmienkujte, či to nieje prázdne
Sub CheckExists()
Dim rngRed As Range, rngGreen As Range, Cell As Range, V, Pos As Integer
For Each Cell In Selection.Cells
V = Cell.Value
If Not IsEmpty(V) Then
Pos = InStrRev(V, ".")
If Len(Dir(Left$(V, IIf(Pos = 0, Len(V), Pos - 1)) & "*")) = 0 Then AddColor rngRed, Cell Else AddColor rngGreen, Cell
End If
Next Cell
If Not rngRed Is Nothing Then rngRed.Font.Color = vbRed
If Not rngGreen Is Nothing Then rngGreen.Font.Color = vbGreen
End Sub
alebo najlepšie checkujte iba prienik Vašeho výberu Selection s obsadenou časťou listu
Sub CheckExists()
Dim rngRed As Range, rngGreen As Range, ARE As Range, Oblast As Range, Cell As Range, V, Pos As Integer
Set Oblast = Intersect(ActiveSheet.UsedRange, Selection)
If Oblast Is Nothing Then MsgBox "Žiadne data": Exit Sub
For Each ARE In Oblast.Areas
For Each Cell In ARE.Cells
V = Cell.Value
If Not IsEmpty(V) Then
Pos = InStrRev(V, ".")
If Len(Dir(Left$(V, IIf(Pos = 0, Len(V), Pos - 1)) & "*")) = 0 Then AddColor rngRed, Cell Else AddColor rngGreen, Cell
End If
Next Cell
Next ARE
If Not rngRed Is Nothing Then rngRed.Font.Color = vbRed
If Not rngGreen Is Nothing Then rngGreen.Font.Color = vbGreen
End Sub
2000 súborov mi to kontroluje asi 0,5 sekundy, a to pri označení celého stĺpca.
Tak vyskúšajte.
Skúšať výhradne na kópii súboru !
Ale samozrejme, veď nemáte vyplnené B. Ak v B nič nieje, pre dátum je to ako 0. a nultý dátum je samozrejme minimálny možný, preto ho nájde ako minimum. Minimálny dátum (teda dátum 0, aj keď je to nezmysel) je 0.1.1900.
Takže si adekvátne upravte :
Maticovo:
=MIN(IF((C3:C99999="")*(B3:B99999<>0);B3:B99999;FALSE))
=MIN(KDYŽ((C3:C99999="")*(B3:B99999<>0);B3:B99999;NEPRAVDA))
Nematicovo:
=AGGREGATE(15;6;B3:B99999/((B3:B99999<>"")*(C3:C99999=""));1)
Uživatelské menu
\nMenu
On-line nástroje
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
RSS nejnovější články