07. januar 2011 - 16:14Der er
16 kommentarer og 1 løsning
Hjælp til at slette et stort antal rækker i excel +24.000 rækker
Hej min første post så håber jeg gør dette forståeligt. Jeg har et excel ark, med +24000 rækker, det er en regnskabsdatabase... Jeg vil gerne slette alle rækker hvor 12 specifikke celler ALLE er 0.. Følgende løser dette problem:
Sub Deleterowswith0()
Dim A, B As Integer
Cells(4, 12).Activate Do Until Cells(ActiveCell.Row, 1) = "" A = 0 Do While A < 37
If Cells(ActiveCell.Row, 12 + A).Value <> 0 Then Exit Do End If
If A = 36 Then B = ActiveCell.Row - 1 ActiveCell.EntireRow.Delete Cells(B, 12).Activate
End If
A = A + 1 Loop Cells(ActiveCell.Row + 1, 12).Activate Loop
End Sub
Makroen virker perfekt, eneste problem er at det vil tage et par timer at kører igennem.. Det jeg gerne vil er, at istedet for at slette en række af gangen, vil jeg gerne gemme deres position og makere dem efterfølgende og slette dem samlet, så det går hurtigere... Er der nogen som har svar på dette, eller dele af dette?
Du siger det er 12 specifikke celler, udfra din kode, så regner jeg ikke med cellerne ligger op ad hinanden, da du køre 37 celler igennem?
Istedet kunne du fx. lave en sammentælling på de specifikke celler det drejer sig om - ved godt selve linien bliver lang, men tiden for at udregne det, burde være noget hurtigere.
fx. A = activecell.offset(0,0).value + activecell.offset(0,3).value altså A = den celle du står i + cellen tre pladser til højre for, også udvider du den blot med de celler du skal bruge.
bagefter kan du tjekke om tallet så er 0: If A = 0 then 'tilføj til en liste end if Dette går dog kun hvis tallene er > -1 Hvis tallene kan være negative, så må du lige sige til, så skal jeg prøve at kigge videre på den del.
omkring lagring af hvilke rækker der skal slettes, så kan du gøre det, at du opretter et array. dim minListe() as string ' denne er dynamisk finder så ud af hvor mange indput der skal være plads til - hvor mange celler der er og laver redim minListe(1 to sidste)
når du så har gemt alle celler i listen og skal til at vælge alle rækkerne, så har jeg fået følgende til at virke: dim r as range For i = 1 To sidste If r Is Nothing Then Set r = Rows(a(i) & ":" & a(i)) Else Set r = Union(r, Rows(a(i) & ":" & a(i))) End If Next r.Select
En ekstra mulighed for at sætte lidt ekstra fart på, så kan du bruge følgende kode før du begynder at slette rækker:
With Application .Calculation = xlCalculationManual .ScreenUpdating = False End With
og efter sletningen:
With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With
Det er gik lige lidt hurtig med at skrive det hele, så beklager hvis det virker usammenhængen... Men skal nok smide min samlet kode senere - ved ikke om jeg når det efter aftensmaden eller det først bliver efter hockey.
Her er mit forslag... skulle gerne virke, men har ikke lige testet det ordenligt igennem:
Sub Deleterowswith0()
Dim A As Integer Dim minListe() As String Dim sidste, index As Integer Dim r As Range
index = 1 sidste = Range("A65536").End(xlUp).Row ReDim minListe(index To sidste) Cells(4, 12).Activate Do Until Cells(ActiveCell.Row, 1) = "" A = ActiveCell.Offset(0, 0).Value + ActiveCell.Offset(0, 3).Value ' tilføj de celler der skal tjekkes (0,0) = L-kolonnen, (0,1) = M-kolonnen osv. If A = 0 Then minListe(index) = ActiveCell.Row index = index + 1 End If Loop
For i = 1 To index If r Is Nothing Then Set r = Rows(A(i) & ":" & A(i)) Else Set r = Union(r, Rows(A(i) & ":" & A(i))) End If Next r.Select
With Application .Calculation = xlCalculationManual .ScreenUpdating = False End With
Selection.Delete
With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With
Kan se at jeg har glemt at ændre et par ting, og skifte aktiv celle... så du får lige en ny her, som virker hos mig:
Sub Deleterowswith0()
Dim A As Integer Dim minListe() As String Dim sidste, index As Integer Dim r As Range
index = 1 sidste = Range("A65536").End(xlUp).Row ReDim minListe(index To sidste) Cells(4, 12).Activate Do Until Cells(ActiveCell.Row, 1) = "" A = ActiveCell.Offset(0, 0).Value + ActiveCell.Offset(0, 2).Value ' tilføj de celler der skal tjekkes (0,0) = L-kolonnen, (0,1) = M-kolonnen osv. If A = 0 Then minListe(index) = ActiveCell.Row index = index + 1 End If ActiveCell.Offset(1, 0).Select Loop
For i = 1 To index - 1 If r Is Nothing Then Set r = Rows(minListe(i) & ":" & minListe(i)) Else Set r = Union(r, Rows(minListe(i) & ":" & minListe(i))) End If Next r.Select
With Application .Calculation = xlCalculationManual .ScreenUpdating = False End With
Selection.Delete
With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With
Jeg ser forslagene igennem... da det er en regnskabsdatabase kan resultatet godt blive negativt... Der er 37 celler på en række som skal være 0 (alle sammen).. hvis alle er 0 skal rækken slettes.. hvis en ikke er 0 skal de ikke slettes...
Min formel virker perfekt, undtagen at det tager et år at køre... så delete delen skal endres til at det hele slettes samtidig så det går hurtigere... vil teste nu..
Ved godt at din kode virker omkring at tjekke cellerne for 0, men det burde være hurtigere blot at lave en formel istedet for et loop som skal tage en celle af gangen. Jeg har følgende forslag efter den nye info omkring 37 celler på række:
Sub Deleterowswith0()
Dim A As Integer Dim minListe() As String Dim sidste, index As Integer Dim r As Range Dim celle As String
index = 1 sidste = Range("A65536").End(xlUp).Row ReDim minListe(index To sidste) Cells(4, 12).Activate Do Until Cells(ActiveCell.Row, 1) = "" celle = ActiveCell.Column celle = "L" & celle & ":AV" & celle A = Application.CountIf(Range(celle), 0) If A = 37 Then minListe(index) = ActiveCell.Row index = index + 1 End If ActiveCell.Offset(1, 0).Select Loop
For i = 1 To index - 1 If r Is Nothing Then Set r = Rows(minListe(i) & ":" & minListe(i)) Else Set r = Union(r, Rows(minListe(i) & ":" & minListe(i))) End If Next r.Select
With Application .Calculation = xlCalculationManual .ScreenUpdating = False End With
Selection.Delete
With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With
Indsæt formlen i første ledige kolonne i række 2 =TÆL.HVIS(L2:AV2;0) ret evt L2:AV2 til aktuel, og kopier ned Sæt Autofilter på og vælg 37 som filter i den kolonne hvor formlen er Slet de synlige rækker
For i = 1 To index - 1 If r Is Nothing Then Set r = Rows(minListe(i) & ":" & minListe(i)) Else Set r = Union(r, Rows(minListe(i) & ":" & minListe(i))) End If Next r.Select
With Application .Calculation = xlCalculationManual .ScreenUpdating = False End With
Selection.Delete
With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With
End Sub
Problemet er at den stopper når den når til 6350 (mener det er index der når til dette tal), på alt under virker den perfekt.. Men nu er der jo 24000+ linier
Ideen er at få den til at tage det i bidder, men det har jeg lidt bøvl med... Jeg ønsker at teste 6000 linier slette dem som skal slettes, og fortsætte hvor jeg kom fra... jeg har problemer med at nulstille "index r"
Sub Deleterowswith0()
Dim A As Double Dim minListe() As String Dim sidste, index As Integer Dim r As Range Dim B As Integer Dim C As Integer Dim D As Integer
sidste = Range("A65536").End(xlUp).Row ReDim minListe(index To sidste) Cells(4, 12).Activate B = 0 C = 0 Do Until Cells(ActiveCell.Row, 1) = "" D = 0 index = 1
Do While Cells(ActiveCell.Row) = "" If D = 5000 Then Exit Do Cells(4 + B - C, 12).Activate
'Hvis A møder den krævede kriterie gemmes den på listen If A = 0 Then minListe(index) = ActiveCell.Row index = index + 1 C = C + 1 End If Loop
ActiveCell.Offset(1, 0).Select
'Her defineres listens rækker i "r" For i = 1 To index - 1 If r Is Nothing Then Set r = Rows(minListe(i) & ":" & minListe(i)) Else Set r = Union(r, Rows(minListe(i) & ":" & minListe(i))) End If Next
'Vælg de gemte informationer i "r" r.Select
'Dette slåes fra for at gøre processen hurtigere With Application .Calculation = xlCalculationManual .ScreenUpdating = False End With
'Slet de valgte informationer Selection.Delete
'Dette slåes til efter sletningen With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With
raekke = raekke + 1 count = count + 1 'Hvis A møder den krævede kriterie gemmes den på listen If A = 0 Then minListe(index) = ActiveCell.Row index = index + 1 End If Loop raekke = raekke - index ActiveCell.Offset(1, 0).Select
'Her defineres listens rækker i "r" For i = 1 To index - 1 If r Is Nothing Then Set r = Rows(minListe(i) & ":" & minListe(i)) Else Set r = Union(r, Rows(minListe(i) & ":" & minListe(i))) End If Next
'Vælg de gemte informationer i "r" r.Select
'Dette slåes fra for at gøre processen hurtigere With Application .Calculation = xlCalculationManual .ScreenUpdating = False End With
'Slet de valgte informationer Selection.Delete
'Dette slåes til efter sletningen With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With
raekke = raekke + 1 count = count + 1 'Hvis A møder den krævede kriterie gemmes den på listen If A = 0 Then minListe(index) = ActiveCell.Row index = index + 1 End If Loop raekke = raekke - index + 1 ActiveCell.Offset(1, 0).Select
'Her defineres listens rækker i "r" For i = 1 To index - 1 If r Is Nothing Then Set r = Rows(minListe(i) & ":" & minListe(i)) Else Set r = Union(r, Rows(minListe(i) & ":" & minListe(i))) End If Next
'Vælg de gemte informationer i "r" r.Select
'Dette slåes fra for at gøre processen hurtigere With Application .Calculation = xlCalculationManual .ScreenUpdating = False End With
'Slet de valgte informationer Selection.Delete
'Dette slåes til efter sletningen With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With
@newbieatphp Koden virker som den skal, selve sletningen tager dog noget tid, men det kan vist ikke optimeres, tak for hjælpen... hvordan tildeler jeg point?
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
