< návrat zpět

MS Excel


Téma: VBA mazani dat s podminou rss

Zaslal/a 20.1.2019 17:45

Merlin99Zdravim vsechny potreboval bych momost s jednim makrem ktere by umelo nasledujici. Ve slouoci H je seznam materialu a ve sloupci I se knim dotahuje text. Pokud text skonci err tak bych potreboval dany material ve slpupci H pouze vymazat (delete). Pokud nekdo elegantne dokaze budu rad. Děkuji moc viz priloha

Příloha: rar42472_mazani-err.rar (11kB, staženo 21x)
Jméno
Kontrola
Text
  b i u s img code url hr   1 2 3 4 5 6 7 8 9 10

#042476
elninoslov
Sub Vymaz_Err()
Dim PrvniRadekDat As Long, PoslRadekDat As Long, Radku As Long, SloupecDat As Integer, Data(), i As Long, rngErr As Range

PrvniRadekDat = 5
SloupecDat = 9

With ThisWorkbook.Worksheets("DATA")
PoslRadekDat = .Cells(.Rows.Count, SloupecDat).End(xlUp).Row
If PoslRadekDat < PrvniRadekDat Then MsgBox "Žádná data.", vbInformation: Exit Sub
Radku = PoslRadekDat - PrvniRadekDat + 1
ReDim Data(1 To Radku, 1 To 1)
If Radku = 1 Then Data(1, 1) = .Cells(PrvniRadekDat, SloupecDat).Value Else Data = .Cells(PrvniRadekDat, SloupecDat).Resize(Radku).Value
For i = 1 To Radku
If Data(i, 1) = "err" Then
If rngErr Is Nothing Then Set rngErr = .Cells(PrvniRadekDat + i - 1, SloupecDat - 1) Else Set rngErr = Union(rngErr, .Cells(PrvniRadekDat + i - 1, SloupecDat - 1))
End If
Next i
If Not rngErr Is Nothing Then rngErr.ClearContents
End With
End Sub
Příloha: zip42476_mazani-err.zip (17kB, staženo 21x)
citovat
#042478
Merlin99
elninoslov: Díky moc je to dokonalé :))) skvělá práce. DÍKYcitovat
#042527
Stalker
Tak trochu zneužiji toto vlákno.
Měl sem vymyšlené řešení pomocí pole, než sem však stačil zareagovat (byl sem v práci na mobilu) elnino poskytl řešení.

Nedalo mi to a dneska sem vyplodil dva kódy, a tady je vlastně můj dotaz. Primárně se týká druhého kódu (Vymaz_Err_3). Vidíte v něm nějakou zásadní slabinu nebo chybu proč takhle né?
Má domněnka je, že by měl být v případě většího počtu dat rychlejší - počet průchodů cyklu bude roven počtu (chyb) výskytu hodnoty err.

Autor dotazu může případně otestovat na větším počtu položek.

PS: Pokud by někdo věděl jak do uvedeného kódu dostat převod řetězce na malá písmena (při porovnání) stejně jako je tomu v Vymaz_Err_2 budu jen rád.

Díky
Příloha: zip42527_mazani-err.zip (19kB, staženo 17x)
citovat
#042529
elninoslov
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 ... :)citovat
#042542
elninoslov
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
Příloha: zip42542_mazani-err.zip (301kB, staženo 18x)
citovat
#042553
Stalker
Teda chlape, ty ses do toho pustil. Ten Tvůj kód (první) vychází nejlépe. Ten zbytek se tak nějak mezi sebou mele, i když by se M$ za tem Timer ve VBA měl stydět. Pokud spustím test ještě jednou výsledky se absolutně změní a u některých procedur vrací 0,0000 ms.

Hlavní je, že myslet znamená h.... vědět. A to co sem si původně naivně myslel, že bude rychlejší, tak není.

Díky za čas, který si tomu věnoval.
Jo a s tím editem máš naprostou pravdu, v jednoduchosti je síla. 10citovat
#042554
elninoslov
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...
Hawkcitovat

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

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.

Aktivní diskuse

Současné rozplánování více projektů v Excelu.

eLCHa • 2.3. 22:03

Oddělovač polí

Milan-158 • 1.3. 16:01

Oddělovač polí

Whooocak • 1.3. 15:14

Vkládání dat z formuláře na zamknutém listu.

Milan-158 • 1.3. 15:12

Vlastne planovanie zmien

Anonym • 1.3. 7:56

Vkládání dat z formuláře na zamknutém listu.

Začátečník • 28.2. 19:34

Vkládání dat z formuláře na zamknutém listu.

Zdenys84 • 28.2. 19:05