RSS

Betinget sletning af rækker i tabel

Jeg har ofte brug for at slette rækker i en tabel, hvis værdier i en given kolonne er større eller mindre end et eller andet.

Det kan fx være poster/rækker, hvor en maskine ikke kører, eller hvor produktionen er under en eller anden værdi.

Det kan man selvfølgelig også gøre manuelt ved først at lade Excel sortere data, men det er nemmere og hurtigere at bruge makroer. Herunder viser jeg et eksempel på, hvordan det kan gøres.

Koden benytter sig bl.a. af Ranges, Arrays, UserForms (også modeless), Listboxe, løkker og en funktion, som returnerer True eller False. Eksemplet bruger kun talværdier som kriterium, men det kan nemt ændres.

Det er nok vigtigt at pointere, at det ikke er hele rækken, der slettes i regnearket. Det er kun rækken i tabellen, og der er ikke noget med, at rækker nedenunder (uden for tabellen) "hopper opad".

Da jeg normalt arbejder med data importeret fra tekstfiler (eller csv), har jeg makroen i ét regneark, som så opererer på et andet regneark med de importerede data. Hvis data er i samme regneark som makroen, skal koden modificeres.

Et zipkomprimeret regneark med eksemplet kan downloades her, men vær opmærksom på, at kommentarerne er på engelsk.

Firmaet Webucator, som tilbyder undervisning i VBA, har lagt en video på YouTube, som viser makroerne i funktion.

Videoen forklarer ikke i detaljer, hvordan koden virker (i den henseende får du mere ud af mine kommentarer til koden her på siden), men man får et indtryk af, hvordan den kører.

Nå, vi skal i gang - først nogle variable, som skal defineres øverst i modulet, og dernæst startproceduren.


Option Explicit
Public bSmaller As Boolean
Public bEquals As Boolean
Public bGreater As Boolean
Public bAbort As Boolean
Public lSelCol As Long
Public dSortVal As Double

Sub OpenSort()
'Fjerner rækker som opfylder et brugerdefineret
'kriterium baseret på værdier i én kolonne,
'fx at værdien er større eller mindre end et
'eller andet.

Dim vInput

On Error GoTo ErrorHandle

'Viser en MsgBox for brugeren
vInput = MsgBox("Fjerner rækker i tabellen, hvor værdier i 1 kolonne " _
& vbNewLine & _
"opfylder et brugerdefineret kriterium, som " & vbNewLine & _
"fx at værdien er større eller mindre end X. " & vbNewLine & _
"Vær opmærksom på, at tal i tabellen kan være afrundede.", _
vbOKCancel, "Fjern rækker")
              
'Hvis brugeren trykkede Annuller
If vInput = vbCancel Then Exit Sub

'Tabellen med data forventes at være i et andet regneark
If Workbooks.Count = 1 Then
   MsgBox "Kun dette regneark er åbent."
   Exit Sub
ElseIf Workbooks.Count = 2 Then
   If Workbooks(Workbooks.Count).Name = ThisWorkbook.Name Then
      Workbooks(1).Activate
   Else
      Workbooks(Workbooks.Count).Activate
   End If
   Criteria 'Procedurekald
Else
   'Hvis der er mere end 2 regneark åbne,
   'skal brugeren aktivere det rigtige (med data)
   Workbooks(Workbooks.Count).Activate
   With frmPickSheet
      'Fra og med Excel 2013 "svæver" en modeless UserForm
      'ikke længere øverst, men ved at sætte StartUpPosition = 3
      'vil den komme i øverste venstre hjørne, og så er den lettere
      'at finde, når man har 2 åbne vinduer.
      .StartUpPosition = 3
      .Show vbModeless
   End With
End If

Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure OpenSort"
End Sub

Som man ser sidst i proceduren, viser vi en UserForm (frmPickSheet), hvis der er mere end 2 åbne regneark.

Normalt har en UserForm "focus," og man kan ikke foretage sig noget, før formularen er lukket, men ved at tilføje "vbModeless" svæver den bare, så brugeren kan foretage sig andre ting - her at aktivere det regneark og faneblad, som indeholder vores data.

I regnearket, du kan downloade, ser den således ud:

Modeless UserForm

Formularen har kun følgende kode, hvor "cmdOK" er navnet på OK-knappen:


Private Sub cmdOK_Click()

On Error GoTo ErrorHandle

Unload Me

Criteria 'Procedurekald

Exit Sub
ErrorHandle:
MsgBox Err.Description
End Sub

Proceduren Criteria følger her. Først vises en UserForm, frmSelectColumn, med en ListBox, hvor brugeren skal vælge kolonnen, som indeholder nøgleværdierne - altså de værdier, som ligger til grund for, om der skal slettes rækker eller ej.

Dernæst vises en UserForm, hvor brugeren skal angive kriteriet for sletning, fx værdier under 4000.

Dernæst kopieres tabellen til et array, MyArray. Her gennemløbes kolonnen, og rækker, som ikke skal slettes, kopieres til et andet array, NewArray. Den gamle tabel slettes i regnearket, og den nye kopieres ind fra NewArray, og så er vi færdige.


Sub Criteria()
Dim bDelete As Boolean
Dim MyArray() As Variant    'Udgangsarrayet
Dim NewArray() As Variant   'Resultatarrayet
Dim rCell As Range          'Rangevariabel
Dim rTable As Range         'Rangevariabel
Dim lRows As Long           'Antal rækker
Dim lCols As Long           'Antal kolonner
Dim lCount As Long          'Tæller
Dim lCount2 As Long         'Tæller
Dim lCount3 As Long         'Tæller
Dim lDelete As Long         'Tæller
Dim lStartRow As Long

On Error GoTo ErrorHandle

If Len(Range("A1").Value) = 0 Then
    MsgBox "Tabellen skal starte i celle A1."
    Exit Sub
End If

'Vælg kolonnen, der skal bruges
frmSelectColumn.Show

If bAbort Then
   bAbort = False
   GoTo BeforeExit
End If

'Definér kriterium
frmCriteria.Show
If bAbort Then
   bAbort = False
   GoTo BeforeExit
End If

Application.ScreenUpdating = False

'Sætter rTable = tabellen
Set rTable = Range("A1").CurrentRegion

With rTable
   lCols = .Columns.Count 'Antal kolonner
   lRows = .Rows.Count    'Antal rækker
End With

'Tabellen kopieres til MyArray
MyArray = rTable.Value

'Frigør hukommelse
Set rTable = Nothing

'Finder første række med en numerisk værdi.
'Her starter gennemløbet.
For lCount = 1 To lRows
   If IsNumeric(MyArray(lCount, lSelCol)) Then
      lStartRow = lCount
      Exit For
   End If
Next

If lStartRow = lRows Then
   MsgBox "Kolonnen indeholder ingen numeriske værdier."
   GoTo BeforeExit
End If

'Nu gennemløbes kolonnen i arrayet
For lCount = lStartRow To lRows Step 1
   'Hvis værdien er numerisk
   If IsNumeric(MyArray(lCount, lSelCol)) Then
      'Kalder funktion DeleteRow som returnerer
      'True eller False om rækken skal slettes
      bDelete = DeleteRow(MyArray(lCount, lSelCol))
      If bDelete = True Then
         MyArray(lCount, 1) = "delete"
         lDelete = lDelete + 1
      End If
   End If
Next

If lDelete = 0 Then
   MsgBox "Ingen værdier opfyldte kriteriet."
   GoTo BeforeExit
End If

'Redimensionerer det array hvortil tabellen
'(minus de slettede rækker) skal kopieres.
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

'Sletter den gamle tabel
Set rTable = Range("A1").CurrentRegion
rTable.ClearContents

'Definerer et nyt range startende i celle A1
'med de samme dimensioner som NewArray.
Set rTable = Range("A1")
Set rTable = rTable.Resize(UBound(NewArray), lCols)

'NewArray kopieres til tabellen i ét hug.
rTable.Value = NewArray

BeforeExit:
On Error Resume Next
Erase MyArray
Erase NewArray
Set rTable = Nothing
bAbort = False
lSelCol = 0
Application.ScreenUpdating = True

Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure Criteria"
Resume BeforeExit
End Sub

Undervejs kaldte vi 2 UserForms, frmSelectColumn og frmCriteria, for at få input fra brugeren.

I regnearket, du kan downloade, ser de således ud. Først frmSelectColumn med kode:

Listbox

Koden finder selv kolonneoverskrifterne, hvis der er nogen. Her følger den kode, som hører til frmSelectColumn.


Private Sub UserForm_Initialize()
'Eksekverer før formularen åbner
Dim rCell As Range
Dim rRow As Range

If IsEmpty(Range("A1")) Then
   MsgBox "Celle A1 er tom - programmet afbrydes."
   bAbort = True
   Unload Me
End If

If IsEmpty(Range("B1")) = False Then
   Set rRow = Range(Range("A1"), Range("A1").End(xlToRight))
   For Each rCell In rRow
      ListBox1.AddItem rCell.Value
   Next
Else
   ListBox1.AddItem Range("A1").Value
End If

BeforeExit:
Set rCell = Nothing
Set rRow = Nothing
Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure UserForm_Initialize"
Resume BeforeExit
End Sub

Private Sub CommandButton1_Click()
'OK-knappens klikprocedure
With ListBox1
   If .ListIndex = -1 Then
      MsgBox "Du skal vælge en kolonne."
   Else
      lSelCol = .ListIndex + 1
      Unload Me
   End If
End With
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'Hvis formularen lukkes ved klik i øverste højre hjørne
If CloseMode = vbFormControlMenu Then
    CommandButton2_Click
End If
End Sub

Private Sub CommandButton2_Click()
'Hvis brugeren har trykket på Cancel
bAbort = True
Unload Me
End Sub

Nu mangler vi kun den formular, hvor brugeren kan angive kriterium for sletning af rækker. I mit eksempel ser den således ud:

Kriterium

og har følgende kode:


Private Sub UserForm_Initialize()
'Eksekverer før formularen åbnes
OptionButton1.Value = True
TextBox1.SetFocus
End Sub

Private Sub OptionButton1_Click()
TextBox1.SetFocus
End Sub

Private Sub OptionButton2_Click()
TextBox1.SetFocus
End Sub

Private Sub OptionButton3_Click()
TextBox1.SetFocus
End Sub

Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'Accepterer kun tal, minus, komma og punktum
Select Case KeyAscii
   Case 44 To 57
   Case Else
      KeyAscii = 0
End Select
End Sub

Private Sub CommandButton1_Click()
'OK-knappens klikprocedure

With TextBox1
   If Len(.Text) > 0 Then
      dSortVal = CDbl(.Text)
   Else
      MsgBox "Der skal angives en værdi."
      Exit Sub
   End If
End With

If OptionButton1.Value = True Then
   bSmaller = True
   bEquals = False
   bGreater = False
End If
If OptionButton2.Value = True Then
   bEquals = True
   bSmaller = False
   bGreater = False
End If
If OptionButton3.Value = True Then
   bGreater = True
   bSmaller = False
   bEquals = False
End If

Unload Me

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'Hvis formularen lukkes ved klik på krydset
'øverst i højre hjørne.
If CloseMode = vbFormControlMenu Then
    bAbort = True
    Unload Me
End If
End Sub

Det sidste, vi mangler, er funktionen, som afgør om en række skal slettes eller ej.


Function DeleteRow(ByVal dVal As Double) As Boolean

If bSmaller Then
   If dVal < dSortVal Then
      DeleteRow = True
      Exit Function
   Else
      DeleteRow = False
      Exit Function
   End If
End If

If bEquals Then
   If dVal = dSortVal Then
      DeleteRow = True
      Exit Function
   Else
      DeleteRow = False
      Exit Function
   End If
End If

If bGreater Then
   If dVal > dSortVal Then
      DeleteRow = True
      Exit Function
   Else
      DeleteRow = False
      Exit Function
   End If
End If

End Function

Det var det. Man kunne godt gøre det muligt at angive flere kriterier, men makroen er faktisk ret hurtig, og så kan man jo bare køre den igen på den nye tabel, hvor rækker er slettet.

Som sagt kan du downloade et regneark med eksemplet. Det er noget nemmere end at kopiere koden fra denne side, da der jo også lige er nogle UserForms at designe.

Relateret: