MS Excel

Zdravím, může mě někdo poradit s makrem. Funguje krásně i při 4000 řádcích. Jen ho potřebuji upravit a nevím jak. Používám ho na mazání řádků kde je EN, jenže já ho potřebuji upravit o to aby mazal i kde je na začátku EN a za ním třeba číslo EN1234. Napsal jsem do makra EN*, ale maže zase jen řádky s EN*. Také bych ho potřeboval rozšířit o další podmínky Z*, S*, B*. To jsem sice dokázal, ale zase maže jen ty řádky kde je přesně Z* ....
Předem díky za radu.

Sub smazatEN()
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
End With
With ActiveSheet
.Select
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
.DisplayPageBreaks = False
Firstrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For Lrow = Lastrow To Firstrow Step -1
With .Cells(Lrow, "A") ' Sloupec s hledanými podmínkami
If Not IsError(.Value) Then
Select Case .Value
Case Is = "EN": .EntireRow.Delete 'podmínka v uvozovkách
End Select
End If
End With
Next Lrow
End With
ActiveWindow.View = ViewMode
With Application
.Calculation = CalcMode
End With
End Sub

Zaslat odpověď >

elninoslov(1.11.2024 14:39)#056934

No problema...
Sub smazat()
Dim Countrow As Long
Dim R As Long, c As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim rngDEL As Range
Dim aVal()
Dim aCon() As String

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
End With

With ActiveWindow
ViewMode = .View
.View = xlNormalView
End With

aCon = Split("EN,Z,S,B", ",")

With ActiveSheet.UsedRange
.Parent.DisplayPageBreaks = False

Countrow = .Rows.Count

If .Column <> 1 Then
MsgBox "Použitá oblast nezačíná sloupcem A", vbExclamation: Exit Sub
End If

If Countrow = 1 Then
ReDim aVal(1 To 1, 1 To 1)
aVal(1, 1) = .Cells(1, 1).Value
Else
aVal = .Columns(1).Value
End If

For R = 1 To Countrow
For c = 0 To UBound(aCon)
If Left(aVal(R, 1), Len(aCon(c))) = aCon(c) Then
If rngDEL Is Nothing Then
Set rngDEL = .Cells(R, 1)
Else
Set rngDEL = Union(rngDEL, .Cells(R, 1))
End If
Exit For
End If
Next c
Next R
End With

If Not rngDEL Is Nothing Then
rngDEL.EntireRow.Select
' rngDEL.EntireRow.Delete
End If

ActiveWindow.View = ViewMode
Application.Calculation = CalcMode
End Sub

Příloha: zip

56934_smazat.zip (14kB, staženo 1x)

citovat

stejzi(3.11.2024 5:16)#056935

Makro mě řádky označilo, ale nesmazalo. Možná proto to při procházení 47.000 řádků trvalo dost dlouho.citovat

elninoslov(3.11.2024 9:29)#056936

To je naschvál tak urobené. Pre kontrolu správnej funkčnosti. V kóde sú 2 riadky. Mazací je vypnutý pomocou apostrofu. Ak si to skontrolujete, tak vypnite Select a zapnite Delete.
rngDEL.EntireRow.Select
' rngDEL.EntireRow.Delete
Makro je urobené tak, aby mazalo všetky riadky naraz. To je výhodné časovo, ale iba do nejakého rozumného počtu. Range sa preťaží. Ak by to trvalo neúmerne dlho (napr. dlhšie ako pôvodný spôsob), tak tam doplním, aby napr. každých 1000 nájdených riadkov vykonalo výmaz. Potom nebude Range preťažovaná.citovat

stejzi(3.11.2024 9:58)#056937

Je to opravdu pomalé. Tak jestli přidat to mazání po 1000. Ještě mám dotaz k sloupečku A. Mám ještě jeden soubor a tam zase potřebuji sloupeček B. Stejné podmínky, jen jiný sloupec. Pokoušel jsem se přijít na to, v kterém řádku mu říct, že chci tentokrát sloupec 2. Ale nedaří se. Díkycitovat

lubo(4.11.2024 0:45)#056941

Pokud budete mazat každý řádek zvlášť tak to bude pomalé vždy.
Rychost odstranění výběru závisí na počtu bloků ve výběru,
tj. je nutné odstaňované řádky spojit do jednoho souvislého bloku.
Řazení je v Excelu také dost rychlé.

Na psaní kódu nemám čas, tedy aspoň shrnu postup:

1. do pomocného sloupce zapamatovat pořadí řádků (není nutné)
2. do pomocného sloupce označit řádky k výmazu 'makrem, vzorcem)
3. seřadit všechny řádky tak, aby řádky k výmazu byly v jednom bloku na konci tabulky
4. smazat označené řádky
5. seřadit zbylé řádky v původním pořadí (pokud to potřebujeme)
6. vymazat pomocné sloupce.citovat

elninoslov(4.11.2024 9:01)#056943

Priložte prílohu s príkladom, ako vyzerajú tie dáta (anonymizované). Nech je vidno aj či a aké sú tam vzorce, dátové typy a formáty. Aj napíšte koľko sa približne nachádza vymazávaných riadkov v 50K tabuľke.
Suverénne najrýchlejšie by bolo, ak tam nie sú vzorce, preliať tie dáta iba v poli cyklom a pôvodné nahradiť.
Lebo ako som písal ja aj lubo, ak je tých subrange v range veľa je to pomalé, inak je to výhodné. Ak tam budú iba dáta, urobil by som to cez pole, ak aj vzorce, tak spomenutou lubovou metódou.

Robil som pokus, na 56K tabuľke, kde bolo k vymazaniu 7200 riadkov. A je to pomalé aj pri rozdelení na 1000 alebo 500 riadkov (nesusediacich) v jednom mazanom range. Meranie času síce ukáže pár sekúnd, ale reálne Excel nereaguje >40s.

Po obede by som mohol mať čas, tak priložte tú prílohu.citovat

stejzi(4.11.2024 10:27)#056944

Žádné vzorce tam nejsou. Jen čistá data. Zkouším vymyslet jak je ořezat ještě před exportem do excelu. Už jsem se dostal ze 40.000 řádků na 4.000.citovat

elninoslov(4.11.2024 18:34)#056945

Nemáte náhodou Office 365 verziu?
Ak áno, tak môžete získať výsledok extrémne rýchlo iba jediným obyčajným vzorcom
=FILTER(A1:C51600;BYROW((LEFT(A1:A51600;{2\1\1\1})={"EN"\"Z"\"S"\"B"})*1;SUM)=0)
=FILTER(A1:C51600;BYROW((ZLEVA(A1:A51600;{2\1\1\1})={"EN"\"Z"\"S"\"B"})*1;SUMA)=0)

Takto by vyzeralo makro, ktoré vypočíta daný vzorec cez EVALUATE. Ako vidíte získať výsledok je 1 riadok, ostatné je omáčka. Zatiaľ do 2. hárku, je možné aj nahradiť do pôvodného, takto som to dal pre kontrolu. Zmenšil som dáta na 10K, aby mi to sem vošlo. Rozdiel medzi 10K vs 50K je takmer nepostrehnuteľný. Celkovo sú to iba desatiny sekundy.
Sub smazat()
Dim V
Dim RNG As Range
Dim Col As Integer, i As Integer
Dim F As String
Dim aF() As String

Col = 1
F = "EN,Z,S,B"

Set RNG = Worksheets("Hárok1").UsedRange

aF = Split(F, ",")
F = """" & Replace(F, ",", """,""") & """"
For i = LBound(aF) To UBound(aF): aF(i) = Len(aF(i)): Next i

V = Evaluate("=FILTER(" & RNG.Address(External:=True) & ",BYROW((LEFT(" & RNG.Columns(Col).Address(External:=True) & ",{" & Join(aF, ",") & "})={" & F & "})*1,SUM)=0)")
'=FILTER(A1:C51600;BYROW((LEFT(A1:A51600;{2\1\1\1})={"EN"\"Z"\"S"\"B"})*1;SUM)=0)

With Worksheets("Hárok2")
.UsedRange.ClearContents
If IsError(V) Then
MsgBox "Žiadne dáta nevyhovujú filtru.", vbExclamation
Else
.Activate

With .Cells(RNG.Row, RNG.Column)
.Resize(UBound(V, 1), UBound(V, 2)).Value = V
.Select
End With
End If
End With
End Sub
Ak nemáte Office 365 pôjdem sa piplať aj s inými verziami...

EDIT:
Pre Office 2024 musí byť vo vzorci explicitne aj LAMBDA
=FILTER(A1:C51600;BYROW((LEFT(A1:A51600;{2\1\1\1})={"EN"\"Z"\"S"\"B"})*1;LAMBDA(A;SUM(A)))=0)
=FILTER(A1:C51600;BYROW((ZLEVA(A1:A51600;{2\1\1\1})={"EN"\"Z"\"S"\"B"})*1;LAMBDA(A;SUMA(A)))=0)

Příloha: zip

56945_smazat_evaluate2.zip (231kB, staženo 3x)

citovat

stejzi(5.11.2024 7:12)#056946

Mám Office 2016, už se mě podařilo vše vyřešit s tím prvním makrem co jste sem dal. Pohrál jsem si se systémem, z kterého exportuji data a ořezal jsem počet řádků. Vše funguje. Díkycitovat

elninoslov(5.11.2024 10:27)#056949

Tu máte všetky 3 verzie. Verzie "pole" a "vzorec" vracajú výsledok zatiaľ do druhého listu (dá sa prerobiť aby nahrádzali pôvodné), a posledná verzia "stĺpce" nahrádza pôvodné. Prvé dve sú najrýchlejšie, ale ak by tam boli nejaké nesúrodé formáty, orámovania a pod, nebude to logicky fachať. Naopak posledný variant "stĺpce" je síce najpomalší, ale ponechá nesúrodé formáty apod.

Verzia "vzorec" v Office 2016 fungovať nebude, ostatné áno.

Příloha: zip

56949_smazat_all_version.zip (238kB, staženo 4x)

citovat

Téma: smazání řádků dle podmínky

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje