VBA code voor verwijderen van rijen

Welies · 24 jan 2011

Hallo,
Onderstaande code gebruik ik om rijen met een lege waarde in kolom G te verwijderen. Het gaat om een tabblad met 218000 rijen. De code werkt, maar gigantisch langzaam. Zit er wellicht een fout in de code waardoor het zo lang duurt of heeft het met het aantal records te maken?

Code:

Sub RijenVerwijderen()

    Sheets("Omzet").Select
    
    Range("E1").Select
    
    Do
    
        ActiveCell.Offset(1, 0).Select
        
        If Left(ActiveCell.Value, 1) = "" Then
        
            Rows(ActiveCell.Row).EntireRow.Delete
            ActiveCell.Offset(-1, 0).Select
        
        End If
    
    Loop Until IsEmpty(ActiveCell.Offset(1, 0))
        

End Sub

Alvast bedankt voor de tips

Warme bakkertje · 24 jan 2011

Een loop vertraagt sowieso de zaken, maak gebruik van de ingebouwde functies van XL

Code:

Sub tst2()
    Columns(7).SpecialCells(4).EntireRow.Delete
End Sub

Welies · 25 jan 2011

Als ik het goed begrijp verwijdert deze code alle lege rijen?

Code:

Sub tst2()
    Columns(7).SpecialCells(4).EntireRow.Delete
End Sub.

Er zijn echter geen lege rijen, alleen lege waarden in kolom E (kolom A t/m D en F t/m G bevatten wel waarden) die verwijderd dienen te worden.

BVD

geep1980 · 25 jan 2011

probeer het volgende eens:

Code:

Sub Delete()
'
' This macro deletes al the lines in sheet Import_Nagios that contain the word Service
'
Application.ScreenUpdating = False

    Const sTOFIND As String = ""                    ' set variable to Host

    Dim rngFound As Range, rngToDelete As Range
    Dim sFirstAddress As String
    
    Application.ScreenUpdating = False                  ' Turn off screen updating
    
    With Worksheets("Omzet").Range("E:E")        
        Set rngFound = .Find( _
                            what:=sTOFIND, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=True)
        
        If Not rngFound Is Nothing Then
            Set rngToDelete = rngFound

            'note the address of the first found cell so we know where we started.
            sFirstAddress = rngFound.Address
            
            Set rngFound = .FindNext(After:=rngFound)
            
            Do Until rngFound.Address = sFirstAddress
                Set rngToDelete = Union(rngToDelete, rngFound)
                Set rngFound = .FindNext(After:=rngFound)
            Loop
        End If
    End With
    
    If Not rngToDelete Is Nothing Then rngToDelete.EntireRow.Delete
    
    Application.ScreenUpdating = True
    
End Sub

Warme bakkertje · 25 jan 2011

Onderstaande code gebruik ik om rijen met een lege waarde in kolom G te verwijderen

Wijzig de 7 in 5 om lege waarden in kolom E te zoeken

exhelp · 25 jan 2011

Gebruik de manier van geep1980 hierboven.
Hier worden de 'te schrappen rijen' eerst toegevoegd aan een array.
Nadat de loop klaar is wordt de ganse array ineens verwijderd.

Werkt een pak sneller!

Mvg,
Exhelp

Welies · 25 jan 2011

Helaas werken beide formules niet naar behoren.
De formule van geep1980 is nu al een half uur bezig, dat gaat handmatig nog sneller. Dat moet met VBA toch ook mogelijk zijn??

Even ter verduidelijking:

Mijn eerste code werkte naar behoren echter veel te traag
Data staat in kolom A:G en moet regel voor regel nagelopen worden door de macro
Macro dient de gehele rij te verwijderen als er in kolom E geen waarde is ingevuld

Warme bakkertje · 25 jan 2011

Zijn de cellen in kolom E echt leeg, of staat er een formule in die geen resultaat teruggeeft. Deze werkt gegarandeerd met lege cellen in kolom E

Code:

Sub tst()
    Columns(5).SpecialCells(4).EntireRow.Delete
End Sub

Cobbe · 25 jan 2011

Of de andere werken heb ik niet getest(zullen ook wel werken)

Maar deze doet het werk in 12 seconden:

Code:

Sub RijenVerwijderen()
   For i = Range("E300000").End(xlUp).Row To 1 Step -1
    If Cells(i, 5) = "" Then Rows(i).EntireRow.Delete
   Next
End Sub

Succes, Cobbe

exhelp · 26 jan 2011

Code:

Sub rijen_verwijderen()

Dim lastrow As Long
Dim a As Integer
Dim rng As Range

With ActiveWorkbook.Sheets(1)

    '*****************************
    'Bepaal laatste rij van blad 1
    '*****************************
    lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row

    '******************************
    'Lege rijen toevoegen aan range
    '******************************
    For a = 1 To lastrow
        With .Cells(a, "E")
            If Not IsError(.Value) Then
                If .Value = "" Then
                    If rng Is Nothing Then
                        Set rng = .Cells
                    Else
                        Set rng = Application.Union(rng, .Cells)
                    End If
                End If
            End If
        End With
    Next a
    
    '*****************
    'Range verwijderen
    '*****************
    If Not rng Is Nothing Then rng.EntireRow.Delete

End With

End Sub

Ik heb bovenstaande niet meer kunnen testen, maar zo zou het moeten werken.

Mvg,
Exhelp

cow18 · 26 jan 2011

voor "normale" zaken zou bovenstaande wel lukken voor bv. 100 lege rijen te verwijderen, maar als je >1.000 zulke rijen wil verwijderen begint dat toch ernstig te vertragen. IK zou meer heil zien om dan met een hulpkolom met een formule te werken.
Dus hoe groot is het bereik ? totaal aantal rijen en aantal te verwijderen rijen ongeveer in grootte-orde ? 10-100-1.000-10.000-100.000 ?

Welies · 26 jan 2011

@Cobbe: script werkt wel. maar weer super langzaam.
@exhelp: ik krijg een foutmeding op "rng.EntireRow.Delete" (methode delete van klasse range is mislukt)
@cow18: het is een bestand van 220.000 rijen (verre van normaal

). Dit is wel een extreem voorbeeld, normaliter zal het wat minder zijn (20.000-50.000)

exhelp · 26 jan 2011

Welies,

Probeer eens:

Code:

Dim a As Integer

te veranderen in

Code:

Dim a As Long

Maar de code van Warme Bakkertje is ongetwijfeld de beste voor jouw geval. Indien je op andere voorwaarden dan 'lege cellen' wil controleren, gebruik dan de mijne...

Welies · 26 jan 2011

@warme bakkertje: had je bericht over het hoofd gezien, mr script gaat iets te grondig te werk: hij verwijdert alle regels (wel lekker snel

)
@exhelp: wederom dezelfde melding

cow18 · 26 jan 2011

hoe goed en snel is deze ?

Code:

Option Explicit

Const hulpkolom As String = "AA"                           'deze kolom wordt gebruikt als hulp, dus voor niets anders
Sub WisLege()
  Dim c As Range, t As Double
  t = Timer
  With Sheets("Omzet")                                     'ons werkblad
    .AutoFilterMode = False                                'eventuele filter uitzetten
    Set c = Intersect(.Columns("E"), .UsedRange)           'gebruikt bereik in de E-kolom
    With c.Offset(, Columns(hulpkolom).Column - c.Column)  'gebruikt bereik in de hulpkolom
      .FormulaR1C1 = "=IF(RC5="""",1,"""")"                'zet formule in hulpkolom zodat lege E-cellen daar een 1 krijgen, de rest leeg
      .AutoFilter 1, "<>"                                  'filter alle niet-lege cellen in de hulpkolom
      .Offset(1).SpecialCells(xlVisible).EntireRow.Delete shift:=xlUp  'delete alle nog zichtbare rijen behalve de 1e
      If .Range("A1").Value = 1 Then .Range("A1").EntireRow.Delete shift:=xlUp  'afhankelijk inhoud ook de 1e deleten
    End With
    .AutoFilterMode = False                                'eventuele filter uitzetten
  End With
  MsgBox Timer - t & " seconden geduurd"
End Sub

exhelp · 26 jan 2011

Welies zei:
@exhelp: wederom dezelfde melding

Welies, ik kan je foutmelding niet nabootsen zonder een voorbeeldbestand, maar aan de melding te zien die je krijgt, lijkt het alsof je een foutief blad controleert.

Verander

Code:

With ActiveWorkbook.Sheets(1)

in

Code:

With ActiveWorkbook.Sheets("Omzet")

Maar zoals ik al zei: de methode van Warme Bakkertje is sneller..

Welies · 26 jan 2011

@cow18: werkt in die zin dat ie net het omgekeerde doet: laat de rijen met de lege waarden in kolom E staan en verwijdert degene met een waarde. Tevens krijg ik een melding:

En ik begrijp de toevoeging van de hulpkolom niet helemaal.

Voor de geinterresseerden een voorbeeldbestandje:
Bekijk bijlage VBA.xls

Warme bakkertje · 26 jan 2011

Met onderstaande 3 min over 60.000 rijen

Code:

Sub tst()
t = Timer
AllRows = Range("E65536").End(xlUp).Row
For i = AllRows To 1 Step -1
    With Range("E" & i)
        If .Value = "" Then .EntireRow.Delete
    End With
    AllRows = AllRows - 1
Next
MsgBox Timer - t & " seconden geduurd"
End Sub

Cobbe · 26 jan 2011

Met deze 215000 rijen in 3 seconden, echt waar.

Code:

Sub Macro3()
    Range("A1:G1").AutoFilter
    ActiveSheet.Range("$A$1:$G$215157").AutoFilter Field:=5, Criteria1:="<>"
    ActiveSheet.Range("$A$1:$G$215157").Copy
With Sheets("Blad3")
    .Paste
    .Columns("F:F").EntireColumn.AutoFit
    .Columns("G:G").EntireColumn.AutoFit
End With
End Sub

Copiëert resultaat zonder lege rijen naar nieuw of bestaand blad.

Succes, Cobbe

cow18 · 26 jan 2011

enkele versies bij elkaar geplaatst in 1 bestand

lukt niet, bestand is plots 2 MB, dus hieronder de laatste versies van macros, zet die allen in module 1 van je bestand. Maak een nieuw werkblad "omzet" en laat ze allen een keer lopen

Code:

Option Explicit

Const hulpkolom As String = "AA"                           'deze kolom wordt gebruikt als hulp, dus voor niets anders
Sub Bart()
  Dim c As Range, t As Double
    Sheets("blad2").Cells.Copy Sheets("omzet").Range("A1")
  t = Timer
  With Sheets("Omzet")                                     'ons werkblad
    .AutoFilterMode = False                                'eventuele filter uitzetten
    Set c = Intersect(.Columns("E"), .UsedRange)           'gebruikt bereik in de E-kolom
    With c.Offset(, Columns(hulpkolom).Column - c.Column)  'gebruikt bereik in de hulpkolom
      .FormulaR1C1 = "=IF(RC5="""",1,"""")"                'zet formule in hulpkolom zodat lege E-cellen daar een 1 krijgen, de rest leeg
      .AutoFilter 1, "<>"                                  'filter alle niet-lege cellen in de hulpkolom
      .Offset(1).SpecialCells(xlVisible).EntireRow.Delete shift:=xlUp  'delete alle nog zichtbare rijen behalve de 1e
      If .Range("A1").Value = 1 Then .Range("A1").EntireRow.Delete shift:=xlUp  'afhankelijk inhoud ook de 1e deleten
    End With
    .AutoFilterMode = False                                'eventuele filter uitzetten
  End With
  MsgBox Timer - t & " seconden geduurd"
End Sub

Sub Cobbe()
  Dim t As Double
  Sheets("blad2").Cells.Copy Sheets("omzet").Range("A1")
  Sheets("omzet").Activate
  t = Timer
    Range("A1:G1").AutoFilter
  With ActiveSheet.Range("$A$1:$G$65000")
    .AutoFilter Field:=5, Criteria1:="<>"
    .Copy
    With Sheets("Blad3")
      .Paste
      .Columns("F:F").EntireColumn.AutoFit
      .Columns("G:G").EntireColumn.AutoFit
    End With
  End With
  MsgBox Timer - t & " seconden geduurd"
End Sub

Sub WarmBakkertje()
Dim t As Double, i As Long, AllRows As Long
t = Timer
 Sheets("blad2").Cells.Copy Sheets("omzet").Range("A1")
  Sheets("omzet").Activate
 
AllRows = Range("E65536").End(xlUp).Row
For i = AllRows To 1 Step -1
    With Range("E" & i)
        If .Value = "" Then .EntireRow.Delete
    End With
    AllRows = AllRows - 1
Next
MsgBox Timer - t & " seconden geduurd"
End Sub

Sub exhelp()

Dim lastrow As Long
Dim a As Integer
Dim rng As Range
 Dim c As Range, t As Double
    Sheets("blad2").Cells.Copy Sheets("omzet").Range("A1")
  t = Timer

With ActiveWorkbook.Sheets("omzet")

    '*****************************
    'Bepaal laatste rij van blad 1
    '*****************************
    lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row

    '******************************
    'Lege rijen toevoegen aan range
    '******************************
    For a = 1 To lastrow
        With .Cells(a, "E")
            If Not IsError(.Value) Then
                If .Value = "" Then
                    If rng Is Nothing Then
                        Set rng = .Cells
                    Else
                        Set rng = Application.Union(rng, .Cells)
                    End If
                End If
            End If
        End With
    Next a
    
    '*****************
    'Range verwijderen
    '*****************
    If Not rng Is Nothing Then rng.EntireRow.Delete

End With
MsgBox Timer - t & " seconden geduurd"
End Sub

VBA code voor verwijderen van rijen

Gebruiker

Meubilair

Gebruiker

Gebruiker

Meubilair

Gebruiker

Gebruiker

Meubilair

Giga Honourable Senior Member †

Gebruiker

Terugkerende gebruiker

Gebruiker

Gebruiker

Gebruiker

Terugkerende gebruiker

Gebruiker

Gebruiker

Meubilair

Giga Honourable Senior Member †

Terugkerende gebruiker

Wij waarderen jouw privacy