Avatar billede Daffodil Professor
22. maj 2017 - 14:28 Der er 20 kommentarer og
1 løsning

Sletning af tomme rækker med VBA

Jeg har et ark på ca. 160.000 rækker hvor jeg skal udsøge de tomme celler i kolonne B fra B2 til sidste post.

Jeg har læst nogle af de forskellige løsnings muligheder her på sitet og andre steder og har fundet mange bud, men ikke noget der virker optimalt. Jeg kan løse problemet med en if - next løkke, men det tager over 20 minutter at gennemføre denne operation. Jeg arbejder pt. med denne her VBA kode:

Set rTable = Range(Selection, ActiveCell.SpecialCells(xlLastCell))

rTable.Select

With rTable
lRow = .Rows.Count
End With

A = "B" & lRow

Range("B2", A).Select

Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Den virker fint hvis jeg f.eks vælger 200 rækker, men hvis jeg kører alle rækkerne på engang sletter den alle data i arker på nær overskriften.

Da række 2 er tom og skal slettes kan jeg ikke umiddelbart brug sorteringfunktionen. Den indbyggede excelfunktion med markering af blanke rækker virker ikke da der er for mange linjer.

Udsøgningen skal være i kolonne B da der kan forekomme data i kolonne A i de rækker der skal slettes. Disse data skal også slettes.

Hvad mangler jeg i kodningen?
Avatar billede acore Ekspert
22. maj 2017 - 14:47 #1
Kan du være mere præcis i forhold til hvornår en række er tom?

Fx: "Den er tom hvis der ikke står noget i kolonne B" eller " Den er tom hvis summen af kolonne C til H er 0". Dette er bare 2 eksempler.

Hvis du kan det, vil det formentlig blive meget hurtigere.

Tror jeg venter med koden, til vi har et bud på ovenstående...
Avatar billede excelent Ekspert
22. maj 2017 - 15:38 #2
Prøv på en kopi

Sub SletRk()
Range("B2:B200000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Avatar billede Daffodil Professor
23. maj 2017 - 07:29 #3
Jeg har uploaded dataarket til Dropboks.

https://www.dropbox.com/s/koq11rllhftre6q/Tabel%20til%20sletning.xlsx?dl=0

Excelent forslag sletter alle rækker på nær overskriften.

Kriteriet for udsøgninger er hvis celle B er tom skal hele rækken slettes. Arket i Dropboks er redigeret således at der kun er fem kolonner med de rigtige data. Hele arket har 68 kolonner. Jeg kan ikke sortere arket før jeg når ovenstående rensning, da jeg flytter indhold fra den underliggende linje til den ovenover. Disse data hænger sammen.
Avatar billede acore Ekspert
23. maj 2017 - 10:04 #4
Har ikke mulighed for at downloade og checke koden på dit ark, men her er den alligevel. Kør DeleteEmptyBRows() for at slette. Koden sætter genberegning i manuel og slår skærmopdatering fra under beregningen. Det er min erfarintg, at det sommetider kan gøre en verden til forskel.

Sub DeleteEmptyBRows()
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
   
    Call DeleteEmptyRows("Sheet1", "B")
   
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

Sub DeleteEmptyRows(s As String, checkCol As String)
    Dim i As Long, lastRow As Long
   
    lastRow = ActiveSheet.UsedRange.row - 1 + ActiveSheet.UsedRange.Rows.Count
   
    With Sheets(s)
        .Select
        For i = lastRow To 1 Step -1
            With .Cells(i, checkCol)
                If .Value = "" Then
                    .EntireRow.Delete
                End If
            End With
        Next
    End With
End Sub
Avatar billede Daffodil Professor
23. maj 2017 - 11:10 #5
Har prøvet at køre kodningen. Den gør at excel "fryser" og jeg bliver nødt til at lukke helt ned for excel for at få liv i den igen.

Jeg kan ændre i koden VBA modulet, men ikke komme i kontakt med excelarkene, når makroen er aktiveret. Noget gør at excel fryser og makroen stopper.
Avatar billede acore Ekspert
23. maj 2017 - 11:43 #6
Har du ventet længe nok?  Jeg mener - den gamle kørte i 20 minutter.

Jeg kan prøve med din fil i aften eller i morgen.

Du kan evt prøve med færre rækker, hvis du vil videre. Koden er testet.
Avatar billede Daffodil Professor
23. maj 2017 - 12:09 #7
Jeg prøver igen, det første gennemløb fik omkring 30 min.

Jeg prøver med færrer rækker.
Avatar billede Jan Hansen Ekspert
23. maj 2017 - 12:25 #8
Avatar billede acore Ekspert
23. maj 2017 - 15:33 #9
Kan godt se, at det trækker tænder ud - min fryser også - i hvert fald i 5 min, så tabte jeg tålmodigheden.

Er det en mulighed at sortere på kolonne B - så får du alle de tomme til sidst? Det klarede jeg på få sekunder.
Avatar billede excelent Ekspert
23. maj 2017 - 15:55 #10
Min kode funker nu fint her, men det tager 8 min
og med 68 kolonner bliver det ikke bedre

Men som acore foreslår, så kan en sortering vel løse problemet.
Avatar billede Daffodil Professor
23. maj 2017 - 16:03 #11
Når jeg forsøger at sortere springer den ned til første tomme linje og sortere kun dem der er over. Hvorledes kan jeg få den til at tage hele arket.

Jeg har forsøgt med excel indbyggede funktion til at fjerne blanke, men jeg kan som sagt ikke få den til at gøre det rigtig. Kan det gøre via VBA?
Avatar billede Mads32 Ekspert
23. maj 2017 - 16:13 #12
Hej

Jeg har prøvet at tilføje en hjælpekolonne i din fil.
I kolonne H indsættes en formel, der giver cellerne i kolonne H værdien 1, hvis cellen i kolonne B er tom, ellers får cellerne værdien 0.

I celle H1 laves en sumformel for optælling af  1-taller(lig antal af tomme linjer)
Sorterer dataområdet på kolonne H, (størst til mindst), så står alle tomme linje øverst( i dit eksempel er der 86419 tomme linjer.

Disse kan nu hurtigt slettes. Jeg sletter med en lille makro, hvor jeg i makroen indtaster antallet af linjer der skal slettes. Jeg har valgt kun at slette 2 linjer af gangen, for at se at det virker som det skal,

Alt i alt en hurtig løsning.

Vedlagt fil

https://www.dropbox.com/s/ta3cchbiyj2j44o/Tabel%20til%20sletning%20Mads32.xlsm?dl=0
Avatar billede Jan Hansen Ekspert
23. maj 2017 - 16:14 #13
Denne fungerer på ca. 70.000 rækker ved ikke hvorfor den ikke funker på flere men måske en anden kan finde ud af det.

Option Explicit
Dim ws As Worksheet
Dim MyArray() As Variant, NewArray() As Variant
Dim rTable As Range
Dim lRows As Long, lCols As Long, lCount As Long
Dim bDelete As Boolean, lDelete As Long
Dim lCount2 As Long, lCount3 As Long
Const LastRow As Long = 500000

Sub RowDelete()
    Screen (False)
    Set ws = ActiveSheet
    Set rTable = ws.Range("A1")
    Set rTable = Range(rTable, rTable.End(xlToRight).Offset(1))
    Set rTable = Range(rTable, rTable.Offset(LastRow, 0))
   
    With rTable
        lRows = .Rows.Count
        lCols = .Columns.Count
    End With
    MyArray = rTable.Value
    Set rTable = Nothing
    For lCount = 1 To lRows
        bDelete = DeleteRow(MyArray(lCount, 2))
        If bDelete = True Then
            MyArray(lCount, 1) = "delete"
            lDelete = lDelete + 1
        End If
    Next
    ReDim NewArray(1 To lRows - lDelete, 1 To lCols)
    For lCount = 1 To lRows
        If MyArray(lCount, 1) <> "delete" Then
          lCount3 = lCount3 + 1
          For lCount2 = 1 To lCols
              NewArray(lCount3, lCount2) = MyArray(lCount, lCount2)
            Next
        End If
    Next
   
    Set rTable = Range("A1").CurrentRegion
    rTable.ClearContents
   
    Set rTable = Range("A2")
    Set rTable = rTable.Resize(UBound(NewArray), lCols)
   
    rTable.Value = NewArray
    On Error Resume Next
    Erase MyArray
    Erase NewArray
    Set rTable = Nothing
    Screen (True)
End Sub
Private Function DeleteRow(ByVal dVal As String) As Boolean
        If dVal = "" Then
            DeleteRow = True
        Else
            DeleteRow = False
        End If
End Function
Private Sub Screen(bOnOff As Boolean)
    Application.ScreenUpdating = bOnOff
End Sub
Avatar billede Jan Hansen Ekspert
23. maj 2017 - 16:18 #14
#13 Tager kun et par sekunder at køre:
Avatar billede Jan Hansen Ekspert
23. maj 2017 - 16:28 #15
Prøv denne tager kun få sekunder

Option Explicit
Dim ws As Worksheet
Dim MyArray() As Variant, NewArray() As Variant
Dim rTable As Range
Dim lRows As Long, lCols As Long, lCount As Long
Dim bDelete As Boolean, lDelete As Long
Dim lCount2 As Long, lCount3 As Long
Const LastRow As Long = 500000

Sub RowDelete()
    Screen (False)
    Set ws = ActiveSheet
    Set rTable = ws.Range("A1")
    Set rTable = Range(rTable, rTable.End(xlToRight).Offset(1))
    Set rTable = Range(rTable, rTable.Offset(LastRow, 0))
   
    With rTable
        lRows = .Rows.Count
        lCols = .Columns.Count
    End With
    MyArray = rTable.Value
    rTable.ClearContents
    Set rTable = Nothing
    For lCount = 1 To lRows
        bDelete = DeleteRow(MyArray(lCount, 2))
        If bDelete = True Then
            MyArray(lCount, 1) = "delete"
            lDelete = lDelete + 1
        End If
    Next
    ReDim NewArray(1 To lRows - lDelete, 1 To lCols)
    For lCount = 1 To lRows
        If MyArray(lCount, 1) <> "delete" Then
          lCount3 = lCount3 + 1
          For lCount2 = 1 To lCols
              NewArray(lCount3, lCount2) = MyArray(lCount, lCount2)
            Next
        End If
    Next
       
    Set rTable = Range("A2")
    Set rTable = rTable.Resize(UBound(NewArray), lCols)
   
    rTable.Value = NewArray
    On Error Resume Next
    Erase MyArray
    Erase NewArray
    Set rTable = Nothing
    Screen (True)
End Sub
Private Function DeleteRow(ByVal dVal As String) As Boolean
        If dVal = "" Then
            DeleteRow = True
        Else
            DeleteRow = False
        End If
End Function
Private Sub Screen(bOnOff As Boolean)
    Application.ScreenUpdating = bOnOff
End Sub

Testet og virker

Jan
Avatar billede Daffodil Professor
24. maj 2017 - 06:35 #16
Mange tak for hjælpen, denne kodning vil jeg lige studere nærmere for at lære hvad den gør.
Avatar billede Jan Hansen Ekspert
24. maj 2017 - 07:15 #17
1. rTable =arket
2. fyldes over i et array, myArray (tabel i hukommelsen)
3. alt i rTable slettes
4. rækker i myArray hvor der er indhold i anden kolonne sendes over i NewArray
5  rTable får samme størrelse som NewArray
6. data fra newArray føres tilbage til rTable
7. bingo
Inspireret af: http://sitestory.dk/excel_vba/slet-raekker-kriterium.htm

Jan
Avatar billede Daffodil Professor
24. maj 2017 - 09:01 #18
Tak for oplysningerne.

Har dog et spg. mere i relation til kodningen.

Når den har overført resultatet er overskrifterne flyttet en række ned.

Jeg prøvede at køre en optælling af rækker og kolonner, hvilket gav ca. 69000 rækker (OK) men 0 kolonner. Dog markerede den hele datasættet. Hvis jeg så sletter den tomme række øverst og gentager optællingen af rækker kolonner, bliver resultatet igen ca. 69000 (minus 1) rækker og 0 kolonner. Hertil markerer den så hele arket som dataområde. Hvorfor dette?
Avatar billede Jan Hansen Ekspert
24. maj 2017 - 10:44 #19
ups Kopi/Sæt ind fejl

    Set rTable = Range("A2")
    Set rTable = rTable.Resize(UBound(NewArray), lCols)

skal rettes til
    Set rTable = Range("A1")
    Set rTable = rTable.Resize(UBound(NewArray), lCols)

Jan
Avatar billede Jan Hansen Ekspert
24. maj 2017 - 11:15 #20
Ny version

Option Explicit
Dim ws As Worksheet
Dim MyArray() As Variant, NewArray() As Variant
Dim rTable As Range
Dim lRows As Long, lCols As Long, lCount As Long
Dim bDelete As Boolean, lDelete As Long
Dim lCount2 As Long, lCount3 As Long
Dim LastRow As Long

Sub RowDelete()
    Screen (False)
    Set ws = ActiveSheet
    Set rTable = ws.Range("A1")
    LastRow = Range("A1", ws.Range("A1000000").End(xlUp)).Rows.Count
    Set rTable = Range(rTable, rTable.End(xlToRight).Offset(1))
    Set rTable = Range(rTable, rTable.Offset(LastRow, 0))
   
    With rTable
        lRows = .Rows.Count
        lCols = .Columns.Count
    End With
    MyArray = rTable.Value
    rTable.ClearContents
    Set rTable = Nothing
    For lCount = 1 To lRows
        bDelete = DeleteRow(MyArray(lCount, 2))
        If bDelete = True Then
            MyArray(lCount, 1) = "delete"
            lDelete = lDelete + 1
        End If
    Next
    ReDim NewArray(1 To lRows - lDelete, 1 To lCols)
    For lCount = 1 To lRows
        If MyArray(lCount, 1) <> "delete" Then
          lCount3 = lCount3 + 1
          For lCount2 = 1 To lCols
              NewArray(lCount3, lCount2) = MyArray(lCount, lCount2)
            Next
        End If
    Next
       
    Set rTable = Range("A1")
    Set rTable = rTable.Resize(UBound(NewArray), lCols)
   
    rTable.Value = NewArray
    On Error Resume Next
    Erase MyArray
    Erase NewArray
    Set rTable = Nothing
    lDelete = 0
    bDelete = False
    lCount3 = 0
    Screen (True)
End Sub
Private Function DeleteRow(ByVal dVal As String) As Boolean
        If dVal = "" Then
            DeleteRow = True
        Else
            DeleteRow = False
        End If
End Function
Private Sub Screen(bOnOff As Boolean)
    Application.ScreenUpdating = bOnOff
End Sub


der er lavet nogle små rettelser og nulstilling af variable

Jan
Avatar billede Daffodil Professor
29. maj 2017 - 08:11 #21
Mange tak for opdateringen.

Har først haft tid nu til at gennemse opdateringen. Burde selv have set den med A2, men det er ikke altid man ser det indlysende. :-)
Avatar billede Ny bruger Nybegynder

Din løsning...

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.

Loading billede Opret Preview

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester