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

Příspěvky uživatele

Alebo aj niečo podobné:
Sub SouhrnDat2()
Dim D() As String, Soubory() As String, Soubor As String, Cesta As String, Pocet As Long

Cesta = ThisWorkbook.Path & "\"
Soubor = Dir(Cesta & "*.xlsx", vbHidden)
While Soubor <> ""
Pocet = Pocet + 1
ReDim Preserve Soubory(1 To Pocet)
Soubory(Pocet) = Soubor

ReDim Preserve D(1 To Pocet)
D(Pocet) = "='" & Cesta & "[" & Soubor & "]List1'!B$1"
Soubor = Dir()
Wend

If Pocet > 0 Then
With List1.Cells(2, 1).Resize(Pocet)
.Value = Application.Transpose(Soubory)
With .Offset(0, 1).Resize(Pocet, 4)
.Formula = Application.Transpose(D)
.Value = .Value
End With
End With
End If
End Sub

Redim poľa a následné Transpose som nepoužil naschvál, kvôli možnosti, že v takom množstve buniek môže byť ľahko aj 32767 hodnôt. No a tam Transpose končí.

EDIT: A ešte treba dať pozor, a vybrať si správne verziu podľa potrieb. Rozdiel je napr. aj v tom, kolegove makro ide zľava doprava, a ak je prázdna cyklus končí. Ja som sa držal zadania, že hodnota môže byť hocikde, nielen zľava.

Možno aj takto. Ale radšej by som zisťoval počet riadkov a stĺpcov, ako to mať na pevno.
Sub VypisCisla()
Dim D(), Sloupcu As Integer, Radku As Long, y As Long, x As Integer, Col As New Collection, Polozka

Sloupcu = 100
Radku = 10000
ReDim D(1 To Radku, 1 To Sloupcu)
D = Worksheets("VSTUP").Cells(2, 1).Resize(Radku, Sloupcu).Value

On Error Resume Next
For x = 1 To Sloupcu
For y = 1 To Radku
If LenB(D(y, x)) > 0 Then
If IsNumeric(D(y, x)) Then Col.Add D(y, x)
End If
Next y
Next x
On Error GoTo 0

With Worksheets("CIL")
.Columns(1).ClearContents
Radku = Col.Count
If Radku > 0 Then
ReDim D(1 To Radku, 1 To 1)
y = 0
For Each Polozka In Col
y = y + 1
D(y, 1) = Polozka
Next Polozka
.Cells(1, 1).Resize(Radku, 1).Value = D
End If
End With
End Sub

Skúste toto
Sub FilterVBA()
Dim Radku As Long, Pole()
With wsSAP.UsedRange
Radku = .Rows.Count - 1
With .Columns(2).Offset(1, 0).Resize(Radku)
ReDim Pole(1 To Radku, 1 To 1)
Pole = .Value2
.NumberFormat = "@"
For i = 1 To Radku
Pole(i, 1) = CStr(Pole(i, 1))
Next i
.Value2 = Pole
End With
.AutoFilter 2, "=20121*", Operator:=xlAnd
End With
End Sub

Ale na generovanie QR kódov sú na tej stránke predsa ďalšie parametre čo som pozeral. A my nevieme aké majú byť použité pre výsledok, ktorý nevidíme, lebo prepojenie na pripojený (nie vložený) obrázok nefunguje.

Zaregistrujte sa a priložte prílohu, aby bolo zrejmé, čo chcete presne urobiť. Ak sa jedná o viacnásobné hľadanie, napr. porovnávanie 2 zoznamov, tak obe tieto metódy sú pomalé. Na to sa dá výhodne a rýchlo použiť Collection. Ak ide o jednorázové použitie v pohode.
Zhrnutie:
ak Application.Match() tak IsError() test, ak WorksheetFunction.Match(), tak On Error Resume Next + If Err.Number <> 0 Then. Ale dá sa použiť aj CountIf, no tá bude ešte pomalšia.
Chce to prílohu.

V tom prípade je treba započítať do toho odsadenie jednoduchou úpravou:
Function ISFILTERED(Col As Range) As Boolean
Dim i As Long, iCol As Long, iRng As Long
Application.Volatile
iCol = Col.Column
With Col.Parent.AutoFilter
iRng = .Range.Column - 1
For i = 1 To .Filters.Count
If .Filters(i).On And i = iCol - iRng Then ISFILTERED = True: Exit For
Next i
End With
End Function
Nevidel som síce prílohu s Rýchlymi filtrami od mepexg, ale tiež ich radšej odporúčam. Ak chcete silou-mocou Podmienený formát a ani táto úprava nieje podľa gusta, priložte súbor nech nehádame.

Prvý odkaz na Google, vzorec:
=MID(CELL("filename";A1);FIND("]";CELL("filename";A1))+1;255)
=ČÁST(POLÍČKO("filename";A1);NAJÍT("]";CELL("filename";A1))+1;255)

Inak makro sa dá upraviť takto:
Function JmenoListu() As String
Application.Volatile
JmenoListu = UCase(List1.Name)
End Function
Prečo musí byť UCase ?

Do prílohy som pridal ešte zistenie názvu iného listu vzorcom aj makrom.

No môžete použiť Podmienené Formátovanie s pomocou UDF:
Function ISFILTERED(Col As Range) As Boolean
Dim i As Long, iCol As Long
Application.Volatile
iCol = Col.Column
With Col.Parent.AutoFilter
For i = 1 To .Filters.Count
If .Filters(i).On And i = iCol Then ISFILTERED = True: Exit For
Next i
End With
End Function
Alebo obdobne to jednorázovo robiť pri WorksheetChange alebo Calculate naraz vyfarbením. Ale pri tomto veľký pozor, už som to tu videl. Vy keď vyfarbíte makrom stĺpec, prídete o Vaše doterajšie farby. To by sa muselo zisťovať po jednom, ktorá bunka má akú farbu, a tieto info niekde ukladať, a potom ich po jednom naspäť vyfarbiť. S takým zošitom by ste pracovať nechcel - bol by veľmi sekaný.

Aj toto PF neviem ako bude fungovať pri početnom filtrovaní.

Na ten časovač by sa dala použiť API, deklarácia možno takto +- autobus (netestoval som na inom ako E2019 x64 + W10 x64)
#If Win64 Then
#If VBA7 Then
Declare PtrSafe Function GetTickCount Lib "kernel32" () As LongPtr
#Else
Declare PtrSafe Function GetTickCount Lib "kernel32" () As LongLong
#End If
Dim TimeMS As LongLong
#Else
Declare Function GetTickCount Lib "kernel32" () As Long
Dim TimeMS As Long
#End If
TimeMS = GetTickCount
.. kód ...
milisekundy=GetTickCount - TimeMS
ale ten tiež vracia nepravidelné hodnoty, čo je spôsobené "optimalizovaným" časovačom Windows, ktorý nieje pravidelný, a má rozptyl 10-16 ms. Vraj kvôli optimalizácii spotreby. Nikdy som sa po tom nepídil, tak neviem, či sa musí trafiť do okna 10-16 inak je 0 alebo predošlý Tick, alebo ako to je. Nepotrebujem to :)
Keď to spustím v testovacej proc, tak dáva pri najrýchlejšej niekedy 0, niekedy 10. Keď samostatne tak 170. Nedá sa na to spoľahnúť. Sú aj iné API. Ale kašle na to pes, stačí pocitovo každé tlačítko zvlášť.

Aj tak by bolo najjednoduchšie a naj user-friendly to SpecialCells...
Hawk

Skúste odstrániť diakritiku, pomlčky, dvojbodky a pod., nechať iba univerzálne písmená, a zmeniť Font na Calibri alebo Arial či Times New Roman, proste taký, ktorý viete, že je na 100% funkčný v CZ/SK.

Problémov môže byť množstvo, od Excelu po Win. Skúsil by som aj aktualizácie, pripadne naopak posledné aktualizácie odstrániť...

Ešte prípadne, si vytvorte nový zošit, kde si vyrobíte (nie kopírovaním) manuálne rovnako vysokú, širokú bunku, s rovnakým typom písma, dáte jej vlastnosť zalamovania a potom tam načisto napíšte rovnaký text. Robí to aj v tom druhom súbore ?

Takto jednoducho ? No jednoducho na jeden riadok ide v makre máločo. A navyše neefektívne pomaly. Ale dá sa to tak, že si nadefinujete Definovaný Názov "NAJDI" s rovnakým vzorcom:
=MATCH(Hárok1!$L$1&Hárok1!$M$1;Hárok1!$A:$A&Hárok1!$B:$B;0)
=POZVYHLEDAT(Hárok1!$L$1&Hárok1!$M$1;Hárok1!$A:$A&Hárok1!$B:$B;0)
z liste ho budete volať normálne :
=NAJDI
a vo VBA :
MsgBox Evaluate("=NAJDI")
Ale rýchlostne neefektívny je aj samotný vzorec, lebo počíta celé stĺpce (milión riadkov).

Ak môže byť makro dlhšie, ale rýchlejšie, dá sa aj inak.

Pr. (NoCaseSensitive):
Function NajdiFnc(Co As String, Optional Opacne As Boolean = False) As Long
Dim AB(), RA As Long, R As Long, i As Long

With List1
RA = .Cells(Rows.Count, 1).End(xlUp).Row
R = .Cells(Rows.Count, 2).End(xlUp).Row
RA = IIf(RA > R, RA, R)
AB = .Cells(1, 1).Resize(RA, 2).Value
R = Opacne And 1
For i = Array(1, RA)(R) To Array(RA, 1)(R) Step Array(1, -1)(R)
If StrComp(AB(i, 1) & AB(i, 2), Co, vbTextCompare) = 0 Then NajdiFnc = i: Exit For
Next i
End With
End Function
použitie zhora, zdola:
MsgBox NajdiFnc("AD")
MsgBox NajdiFnc("AD", True)

Urobil som nejaké úpravy a porovnávaciu procedúru. Ak to robím správne, tak najlepšie vychádza to prvé. Stúpajúcim počtom sa rozdiely vyrovnávajú. Ale nejako sa mi to nezdá, ak máte niekto overenejší nápad ako otestovať dĺžku týchto konkrétnych proc, tak ... mne sa už nece.

EDIT: A zabudli sme na najjednoduchšiu vec. Ak by sa tam nechali normálne chyby a nie "err", tak stačí toto:
On Error Resume Next
List1.Cells(5, 12).Resize(10004).SpecialCells(xlCellTypeFormulas, xlErrors).Offset(0, -1).ClearContents
On Error GoTo 0

Skúste zmazať všetky medzery a napísať ich znovu. Pri Importe textu často nieje medzera (CHAR(160)) ako medzera (CHAR(32)). Vo formáte bunky je teda rozdelenie textu zapnuté, že. Skopírujte text do Wordu a dajte si zobraziť formátovacie znaky, šupnite screen výsledku.

Použitie WorksheetFunction.Match alebo Application.Match je rýchlejšie iba za určitých okolností. Ak je málo výskytov zhody a veľa dát. Ak bude výskytov viac, tak prejdenie poľa bude podľa mňa rýchlejšie. Tam môžete urobiť cez StrComp() porovnanie na NotCaseSensitive. Ak bude dnes čas a chuť porovnám ... :)

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse