Hjælp til at speede VBA-kode op

normalt ville jeg lave en    For i = slut To 17 Step - 1    så rækkerne gennemløbes bagfra når jeg sletter linier... så vil du slipper for i=i-1 og slut=slut-1

Hastighed... der er ikke meget at hente der...

s'føli... Det var lige den, jeg ikke så! Vi lader den lige stå et øjeblik, men smid et svar, flemming, så får du del i den fyrstelige pointsum! ;-D

jeg ville lægge området i en variabel
sortere/teste i den, sætte til Empty hvis sum er 0
og så slette alle tomme i et hug til sidst

har ikke tid før efter kl 16 med ent eks.

Hvad hvis du læser det ind i et array.
Dim myarr()
myarr = Range("C17:E5000")
For i = 1 to slut
s = myarr(i,1)+myarr(i,2)+myarr(i,3)

o.s.v.

jeg smider ikke noget svar - knægten har taget min søvn og tydeligvis noget andet - selvfølgelig kan det indlæses i et array :-)

Hvis du har formler i arket der ikke må slettes, kan du gøre således:

Public Sub slet0linier()
Dim I As Long
slut = Range("C63536").End(xlUp).Row
Dim myarr()
myarr = Range("C17:E" & slut)
    For I = 17 To slut
        Z = myarr(I - 16, 1) + myarr(I - 16, 2) + myarr(I - 16, 3)
        If myarr(I - 16, 1) + myarr(I - 16, 2) + myarr(I - 16, 3) = 0 Then
            omraade = omraade & I & ":" & I & ","
        End If
    Next
omraade = Left(omraade, Len(omraade) - 1)
Range(omraade).Select
Selection.Delete Shift:=xlUp
End Sub

Slet lige linien "Z = myarr(I - 16, 1) + myarr(I - 16, 2) + myarr(I - 16, 3)"

>>> akyhne, efter at have dimmet omraade som range, får jeg nu følgende fejl: "Object variable or With block variable not set" i linien "omraade = omraade & I & ":" & I & ",""

Dim omraade as String

Sub SletNul()

Dim x As Variant
Dim r, c, rk
rk = Range("C65500").End(xlUp).Row
Application.ScreenUpdating = False
x = Range("C17:E" & rk)
For r = LBound(x, 1) To UBound(x, 1)
  For c = LBound(x, 2) To UBound(x, 2)
    If x(r, c) = 0 Then
    x(r, c) = Empty
    End If
  Next
Next
Range("C17:E" & rk) = x
Range("C17:E" & rk).Select
On Error GoTo ingen
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
ingen:
Range("C17").Select
Application.ScreenUpdating = True

End Sub

jeg har ikke testet jeres, her er et alternativ.


Sub SletNul()
    Dim I, rk
    rk = Range("C65500").End(xlUp).Row
    Application.ScreenUpdating = False
    For I = rk To 1 Step -1
        If Application.WorksheetFunction.Sum(Range("C" & I & ":E" & I)) = 0 Then
            Rows(I).EntireRow.Delete Shift:=xlUp
        End If
    Next
    Application.ScreenUpdating = True

End Sub

måske skal automatisk beregning lige slås fra også

Sub SletNul()
    Dim I, rk
    rk = Range("C65500").End(xlUp).Row
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    For I = rk To 1 Step -1
        If Application.WorksheetFunction.Sum(Range("C" & I & ":E" & I)) = 0 Then
            Rows(I).EntireRow.Delete Shift:=xlUp
        End If
    Next
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

alternativ

Sub Makro3()
    Dim slut As Long
    slut = Range("C63536").End(xlUp).Row
    For I = 1 To slut
        If Application.WorksheetFunction.Sum(Range("C" & I & ":E" & I)) = 0 Then
            Range("C" & I & ":E" & I).ClearContents
        End If
    Next
    On Error Resume Next
    Range("E1:E" & slut).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

>>> kabbak og bak, begge jeres virker, men jeg må nu nok sige, at baks forslag vinder på elegance - og især på hurtighed!

Jeg har ikke kunne få akyhne og excelents forslag til at virke, da jeg enten får kørselsfejl eller også blanker den bare 0-cellerne uden at slette de tomme rækker. Men rigtig mange tak for forsøgene, alle sammen!

bak, smid et svar! Pointene er dine!

Private Sub CommandButton1_Click()
Dim I As Long
Dim myarr()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
I = 1
Forfra:
slut = Range("C63536").End(xlUp).Row
myarr = Range("C" & I + poss & ":E" & slut)
Z = 0
    For I = I To slut
        If I < slut - poss Then
            If myarr(I, 1) + myarr(I, 2) + myarr(I, 3) = 0 Then
                omraade = omraade & I + poss & ":" & I + poss & ","
                Z = Z + 1
            End If
        End If
        LL = LL + 1
        If Z = 20 Then GoTo slet:
    Next
slet:
F = F + 20
poss = LL - F
omraade = Left(omraade, Len(omraade) - 1)
I = 1
On Error GoTo slut
Range(omraade).Select
Selection.Delete Shift:=xlUp
omraade = ""
GoTo Forfra:
slut:
Range("C1").Select
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = False
End Sub

det er det med speed, der trigger :-)

x-lars: Hvor mange rækker forventes det at der i 5000 rækker slettes? Jeg kan på ingen måder få bak's kode til at være hurtigere en kabbak's!

Bak >    Range("E1:E" & slut).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

er den ikke lidt farlig, du tjekker kun på E kolonnen, der 'kan' jo være tal i C og D kolonnen

Nej, for hvis summen af C,D,E = 0 fjerner jeg alle værdi i C,D og E med denne linie
Range("C" & I & ":E" & I).ClearContents

(samme sted som du deleter hele rækken enkeltvis)

Ja, der forstås.
Men hvis nu brugeren kun har tastet ind i C eller både C og D, men intet i E, vil den række ikke også blive slettet. ??

Her er lidt målinger:

Procenttallet angiver hvor mange rækker der ca. slettes.

5.000 20%
akyhne 5,1
kabbak 5,6
bak 5,9

5.000 20%
akyhne 5,0
kabbak 5,5
bak 5,7

5.000 50%
akyhne 11,8
kabbak 13,8
bak 13,2

5.000 50%
akyhne 9,9
kabbak 10,9
bak 12,7

20.000 20%
akyhne 19,9
kabbak 19,8
bak 23,9

20.000 50%
akyhne 49,8
kabbak 42,1
bak - sletter alt???

5.000 20%
akyhne 1,3    (20 i kode rettet til 25. Virker kun under 10.000 celler)
kabbak 1,9
bak 2,2

5.000 50%
akyhne 2,3    (20 i kode rettet til 25. Virker kun under 10.000 celler)
kabbak 5,9
bak 6,1

5000 20%  - genstart af Excel for hver kørsel
akyhne 1,2
kabbak 1,9
bak 2,3

Hold da op, gutter! Det her begynder at blive helt videnskabeligt!

Nu har jeg også siddet med stopuret, en frisk tabel (ca. 50% skal slettes) og genstartet Excel for hvert forsøg. akyhnes er faktisk hurtigst på disse præmisser! Til gengæld mener jeg også, at din kode bruger nogle af de teknikker, jeg helst ville undgå, hvor det bliver svært at overskue, hvad koden egentlig laver.

Der er noget, der ligner dødt løb mellem kabbak og bak, og faktisk en lille smule hurtigere til kabbak, når man tager tid på det!

Og kabbak har faktisk en vigtig pointe! I visse af de rappporter, som laver de tabeller, jeg bruger makroen i, kan det forekomme, at der er værdi i C, men ikke i D og E. Kun at fokusere på tomme celler i E-kolonnen medfører en - omend beskeden - fare for, at jeg kommer til at slette linier med værdier i!

Så her vil jeg nok ændre tildelingen og give pointene til kabbak. Håber, at det er acceptabelt for alle parter. Og ellers galper I bare op! Men nok en gang, tusind tak for indsparkene! Det er sjældent, at man når at lære så meget nyt på en dag!

Enig, først nu gik kabbaks pointe op for mig...sorry, det må skyldes demens
lige to spm.
er der formler i arket eller eller det bare rå data ?
vil en sortering ødelægge noget ?

Jeg smider et svar, så må vi se hvad det udvikler sig til.
Bak > jeg er da vist den ældste, så din demens må være på et tidlig stadie ;^))

test lige denne.
Bemærk at den indsætter (og sletter) en sorteringskolonne i BB, dette kan ændres


Sub alternativ()
  Dim i As Long
  Dim slut As Long
  Dim t As Long
  Dim w As Range
  'Start timer
  t = Timer
 
  Application.ScreenUpdating = False

  slut = Range("C63536").End(xlUp).Row
  'indsæt sorteringskolonne og indsæt formel der giver rækkenummer
  Range("BB1").FormulaR1C1 = "=ROW()"
  'fyld nedad
  Range("BB1").AutoFill Destination:=Range("BB1:BB" & slut)
  'gennemtving en kalkulation
  ActiveSheet.Calculate
  'slå så automatisk kalkulation fra
  Application.Calculation = xlCalculationManual
  'Hvis summen af C,D,og E er 0, så fjern alt indhold i rækken
  With Application.WorksheetFunction
      For i = 2 To slut
        Set w = Range("c" & i & ":E" & i)
        If .Sum(w) = 0 Then w.EntireRow.Clear
      Next
  End With
  On Error Resume Next
  'Sorter nu på den indsatte kolonne med rækkenumre
  Range("B1:BB" & slut).Sort Key1:=Range("BB1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
 
  ' Application.Calculation = xlCalculationAutomatic
  'Ryd så den indsatte kolonne
  Range("F:F").Clear
  'sæt skærmopdatering og kalkulation til igen
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  'vis timeren
  MsgBox Timer - t
End Sub

Lige et par mindre korrektioner og forbedringer.

Sub alternativ()
  Dim i As Long
  Dim slut As Long
  Dim t As Long
  Dim w As Range
  'Start timer
  t = Timer

  Application.ScreenUpdating = False
  'slå så automatisk kalkulation fra
  Application.Calculation = xlCalculationManual

  slut = Range("C63536").End(xlUp).Row
  'indsæt sorteringskolonne og indsæt formel der giver rækkenummer
  Range("BB1") = "1"
  'fyld nedad
  Range("BB1").DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Stop:=slut

  'Hvis summen af C,D,og E er 0, så fjern alt indhold i rækken
  With Application.WorksheetFunction
      For i = 2 To slut
        Set w = Range("c" & i & ":E" & i)
        If .Sum(w) = 0 Then w.EntireRow.Clear
      Next
  End With
  On Error Resume Next
  'Sorter nu på den indsatte kolonne med rækkenumre
  Range("B1:BB" & slut).Sort Key1:=Range("BB1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

  ' Application.Calculation = xlCalculationAutomatic
  'Ryd så den indsatte kolonne
  Range("BB:BB").Clear
  'sæt skærmopdatering og kalkulation til igen
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  'vis timeren
  MsgBox Timer - t
End Sub

Set ud fra spørgsmålet - speed er målet - må man jo nu sige at bak nu klart fører. Min kode gik udelukkende ud fra at der skulle slettes rækker, og der fører jeg stadig.

YEEAAARRHH.

Havd gør din som min ikke gør :-)

Den er hurtigere... :-)

Og så tunet en smule:  (ps: akyhne: er dine tider fra før i min eller sekunder?)

Sub alternativ()
  Dim i As Long
  Dim Slut As Long
  Dim t As Long
  'Start timer
  t = Timer

  Application.ScreenUpdating = False
  'slå så automatisk kalkulation fra
  Application.Calculation = xlCalculationManual

  Slut = Range("C63536").End(xlUp).Row
  'indsæt sorteringskolonne og indsæt formel der giver rækkenummer
  Range("BB1") = "1"
  'fyld nedad
  Range("BB1").DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Stop:=Slut

  'Hvis summen af C,D,og E er 0, så fjern alt indhold i rækken
  With Application.WorksheetFunction
      For i = 2 To Slut
        If .Sum(Range("C" & i & ":E" & i)) = 0 Then Rows(i).Clear
      Next
  End With
 
  'Sorter nu på den indsatte kolonne med rækkenumre
  Range("B1:BB" & Slut).Sort Key1:=Range("BB1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

  'Ryd så den indsatte kolonne
  Range("BB:BB").Clear
  'sæt skærmopdatering og kalkulation til igen
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  'vis timeren
  MsgBox Timer - t
End Sub

sekunder...

Indrømmet akyhne, din kode var faktisk smart, selvom den er lidt uoverskuelig :-)

sidder du med en monstermaskine ?
min gamle IBM brugte da 55 sek på din kode med 20000 liner og hver 10 =0

Men den kan selvfølgelig ikke følge med en sortering. Din nye kode kan jeg knap nok må at måle med 5.000 celler. 20.000 celler, 50% tager ca. 3,3 sekunder mod...

akyhne 49,8
kabbak 42,1
bak - sletter alt???

AMD Athlon 2400+, 1Gb ram

Koden kunne sikker også gøres lidt mere forstået. Udgangspunktet var bare at slette så mange rækker som muligt. Excel sætter åbenbart en grænse for, hvor lang stringen i et range må være. Derfor max. 20 ranges ved over 10.000 rækker, og 25 ved under 10.000.

Ideen med 20 range af gange er heller ikke så dum ser det ud til.
den kan måske bruges i et andet afsnit :-)
(Bærbar ibm R51 - 1.5Ghz centrino - 512 Ram)

baks er godt nok hurtig, men en sortering løser ikke mine ønsker, da enkeltrækkerne hører sammen i en hierarki-struktur, som fuldstændig bliver smadret med en sortering.

Så, akyhne, din kode er hurtigst til formålet, men det var primært enkelthed (og forklarlighed), jeg efterspurgte, selvom hastighed bestemt også er en faktor.

Jeg har fået løst mit problem og kører videre med kabbaks kode - så mange tak for den! Derudover har jeg lært en masse, og det aftvinger jo en del ærefrygt, når titanerne på feltet støder sammen på skærmen!

Jeg har oppet pointene og vil nu give 100 til kabbak og 50 til hver af akyhne og bak for anstrengelserne, hvis akyhne også lægger et svar.

Bare en strøtanke - jeg har ikke helt styr på Avanceret filter, men kunne man  sætte det op, så det filtrerede 0-linierne ud?

Vi takker og bukker ;o)

tak for point ;-))

x-lars -> hvis du lægger mærke til det, ændrer min kode på intet tidspunkt på din sortering.
Det er netop derfor at jeg indsætter en kolonne med alle rækkenumrene, som jeg så sorterer på.

Jep, bak, du har - som sædvanligt - ret. Det var min formatering af tabellen (betinget), der gik helt fløjten. Tallene var intakte, men kom til at se meget mærkelige ud.

er godt nok sent på den, til gængæld er den rimelig hurtig

Sub JensLyn()

Dim t, rk
rk = Cells(65500, 3).End(xlUp).Row

For t = 17 To rk
If Application.Sum(Range("C" & t & ":E" & t)) > 0 Then Cells(t, 100) = 1
Next

Range("CV17:CV" & rk).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Range("CV17:CV" & rk) = "" ' hjælpekolonne (100)
ActiveCell.Select

End Sub

er testet på et tomt ark på nær de 200000*3 celler med =1+1 eller =0 (50% 3 ca sek)
så har du mange beregninger, skal beregning nok slås fra ved sammenligning
Application.Calculation = xlCalculationManual

>>> excelent - Excelent! Kors for en sprinter! Man skal bare lige ændre testen til <>0 i stedet for bare >0 - så spiller det! Takker! ;-D

Og - det kan den selvfølgelig ikke finde ud af! Man skal lave to selvstændige testlinier, henholdsvis mindre og større end 0.

På min computer var excelents kode meget langsom???

underligt som man kan få forskellige speed-test resultater
efter min test var min den hurtigste af alle

havde du beregning slået fra akyhne?

både med og uden - samme hastighed.

Opstart af fil, kørsel, luk uden gem.


**********************************
Bærbar AMD64 Turion Mobile 1.8 GHz 512Mb ram

20.000 rækker, 50%

akyhne 26,21
akyhne 26,82

kabbak 21,40
kabbak 26,26

excelent 274,35
excelent 289,40

bak 3,51 - sletter alle celler???
bak 3,57 - sletter alle celler???

---------------------------------

5.000 rækker, 50%
akyhne 1,60
akyhne 1,68

kabbak 1,73
kabbak 1,65

excelent 11,85
excelent 11,89

excelent2 11,78
excelent 11,79

bak 3,37
bak 3,32

***********************************
Stationær AMD Sempron 2400+ 1,67GHz, 1,0GB ram

20.000 rækker, 50%

akyhne 43,70
akyhne 43,76

kabbak 36,37
kabbak 36,04

excelent 301,40
excelent 302,10

bak 4,59  - sletter alle celler???
bak 4,59  - sletter alle celler???

-----------------------------------

5.000 rækker, 50%

akyhne 2,04
akyhne 2,01

kabbak 3,18
kabbak 3,18

excelent 20,17
excelent 19,79

bak 5,09
bak 5,09


***********************************
Stationær AMD Athlon 1,33GHz, 364MB ram

20.000 rækker, 50%

akyhne 67,61
akyhne 69,42

kabbak 55,39
kabbak 55,35

excelent 518,95
excelent 519,26

bak - sletter alle celler???
bak - sletter alle celler???

----------------------------------

5.000 rækker, 50%

akyhne 2,54
akyhne 2,56

kabbak 4,34
kabbak 4,36

excelent 33,43
excelent 33,43

bak 7,51
bak 6,26

***********************************

Jeg lavede i weekenden også nogle test hvor jeg looper gennem hver kode. Her er testen med gem mellem hver kodeafvikling. Loop 4 gange - 5.000 celler 50%:

"akyhne: 9,453
kabbak: 7,093
excelent: 13,26
bak: 7,593
bak2: 0,562

akyhne: 9,593
kabbak: 7,906
excelent: 13,04
bak: 7,890
bak2: 0,718

akyhne: 9,671
kabbak: 7,796
excelent: 15,34
bak: 15,96
bak2: 1,484

akyhne: 10,34
kabbak: 7,906
excelent: 12,95
bak: 7,921
bak2: 1,093

Og her kommer det mystiske. Afvikling af samme loop, men uden ark gem mellem hver afvikling:

akyhne: 8,984
kabbak: 9,859
excelent: 20,98
bak: 22,76
bak2: 0,280

akyhne: 25,20
kabbak: 19,70
excelent: 23,82
bak: 20,71
bak2: 1,593

akyhne: 29,29
kabbak: 19,46
excelent: 23,64
bak: 24,03
bak2: 0,936

akyhne: 21,20
kabbak: 28,59
excelent: 15,73
bak: 30,5
bak2: 0,140

akyhne: 23,79
kabbak: 21,29
excelent: 25,75
bak: 22,67
bak2: 1,437

akyhne: 25,37
kabbak: 24,89
excelent: 18,31
bak: 30,29
bak2: 1,171

min test hvis jeg husker ret med 20000*3 celler
hvor 10000 indeholdt formlen =1+1  fra 1 til 5000 og fra 15000 til 20000
og 10000 indeholdt formlen =0      fra 5000 til 15000
min    ca 2 sek
bak    ca 4 sek
akyhne ca 6 sek
kabbak minutter

bærbar Aspire 3613 WLMi
intel celeron 1.5 GHz 400 MHz FSB, 1MB L2 cache 512 MB DDR2

http://www.racingcar.dk/slet_raekker.xls

jeg tester op imod resultatet af denne makro.

Sub GenSkabTabel()
  With Worksheets(1)
      .Range("B1") = "Overskrift 1"
      .Range("B1").AutoFill Destination:=.Range("B1:E1")
      .Range("G1") = 5
      .Range("B2") = "Test 1"
      .Range("C2").Formula = "=mod(row(),$G$1)"
      .Range("D2").Formula = "=c2"
      .Range("E2").Formula = "=c2"
      .Range("B2:E2").AutoFill Destination:=.Range("B2:E20000")
      .Calculate
  End With
End Sub


I princippet burde excellent's kode og min første kode være nogenlunde lige hurtige da de sletter på samme måde (tilsidst) og det er selve sletningen der tager tiden og ikke loopet.
Ved større områder burde Akyhne kode være hurtigst idet der jævnt hen er frigivet mere hukommelse.
Jeg tror at grunden til at excelent kode i hans egen opstilling er hurtig, skyldes at der er sammenhængende rækker der slettes.


Ved større områder burde

ps. antallet af nul-linier ændres ved at ændre i G1:
5 svarer til at hver femte skal være 0

jeg prøver lige med din opstilling også bak. god ide
og er eller enig i din analyse.

har nu prøvet med akyhne's opstilling, og der er min
kode godt nok sløv - godt 3 min (20000*3 ca 50%) !!!

Hvad siger I så til loopresultatet, hvor der ikke gemmes mellem hver loop (25/09-2006 15:32:21)?
Tiderne svinger jo uhyggelig. Fri systemhukommelse lå konstant på 184-186MB, og swapfilen ændrede ikke størrelse! Og hvorfor stiger alle resultater ved loop, uden gem?

tjaa hvem ved. men det ser godt nok mærkeligt ud