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()
Dim vInput
On Error GoTo ErrorHandle
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")
If vInput = vbCancel Then Exit Sub
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
Else
Workbooks(Workbooks.Count).Activate
With frmPickSheet
.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:
Formularen har kun følgende kode, hvor "cmdOK" er navnet på OK-knappen:
Private Sub cmdOK_Click()
On Error GoTo ErrorHandle
Unload Me
Criteria
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
Dim NewArray() As Variant
Dim rCell As Range
Dim rTable As Range
Dim lRows As Long
Dim lCols As Long
Dim lCount As Long
Dim lCount2 As Long
Dim lCount3 As Long
Dim lDelete As Long
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
frmSelectColumn.Show
If bAbort Then
bAbort = False
GoTo BeforeExit
End If
frmCriteria.Show
If bAbort Then
bAbort = False
GoTo BeforeExit
End If
Application.ScreenUpdating = False
Set rTable = Range("A1").CurrentRegion
With rTable
lCols = .Columns.Count
lRows = .Rows.Count
End With
MyArray = rTable.Value
Set rTable = Nothing
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
For lCount = lStartRow To lRows Step 1
If IsNumeric(MyArray(lCount, lSelCol)) Then
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
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("A1")
Set rTable = rTable.Resize(UBound(NewArray), lCols)
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:
Koden finder selv kolonneoverskrifterne, hvis der er nogen. Her følger den kode, som hører til frmSelectColumn.
Private Sub UserForm_Initialize()
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()
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)
If CloseMode = vbFormControlMenu Then
CommandButton2_Click
End If
End Sub
Private Sub CommandButton2_Click()
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:
og har følgende kode:
Private Sub UserForm_Initialize()
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)
Select Case KeyAscii
Case 44 To 57
Case Else
KeyAscii = 0
End Select
End Sub
Private Sub CommandButton1_Click()
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)
'ø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:
|