Fortløbende nummerering af afkrydsninger
Overskriften
til denne artikel kan nok lyde lidt kryptisk, men det var det bedste, jeg kunne
finde på :-).
Problemstillingen er som følger. I kolonne A sættes et 'x' eller 'X'. Når dette sker, skal der i samme række sættes et tal i kolonne B, således at det første 'x' vil få nummer 1, det næste nummer 2 og så fremdeles. Nummereringen skal være fortløbende uanset hvor i kolonne A, krydserne sættes., fx
Når et 'x' slettes fra kolonne A, skal det tilhørende tal fjernes fra kolonne B. Der er nu to mulige scenarier:
1) Når 'x' slettes fra kolonne A, slettes det relevante tal fra kolonne B, mens de resterende tal bevarer den værdi, de allerede har. Slettes fx 'x' i A5,fjernes 2-tallet i B5, mens de resterende tal i B-kolonnen bevares. Dette kan gøres med nedenstående kode 1.
2) En anden mulighed er, at når et 'x" slettes i b-kolonnen, fx 'x' i A12, slettes tallet ud for dette 'x' og alle tal højere, renummeres, så 5-tallet i B2 bliver til 4 og 6-tallet i B8 bliver til 5. Dette kan gøres med koden i Kode 2.
Da der er tale om en hændelsesprocedure, skal koderne placeres i det relevante arks kodemodul.
Fejlhåndteringen i errhandler, sikrer at man kan markere hele kolonne A og slette indholdet her, og samtidigt få slettet indholdet i B-kolonnen.
NB! De nuværende versioner af koden giver kun mulighed for at slette et 'x' ad gangen, eller alle x'er. Markeres flere x'er i A-kolonnen inden der trykkes Delete, slettes alt indhold i kolonne B. Koderne reagerer på indtastninger i A1 til og med A100, men dette er nemt at ændre.
Kode 1:
Private Sub
Worksheet_Change(ByVal Target As Range)
Dim myval As Long
On Error GoTo errhandler
Set myRange = Worksheets("Ark1").Range("B1:B100")
If Not Intersect(Target, Range("a1:a100")) Is Nothing Then
If UCase(Target.Value) = "X" Then
Target.Offset(0, 1).Value = Application.WorksheetFunction.Max(myRange) + 1
ElseIf Target.Value = "" Then
Target.Offset(0, 1).Value = ""
End If
End If
Exit Sub
errhandler:
If Err.Number = 13 Then
Worksheets("Ark1").Range("B1:B100").Clear
Exit Sub
End If
End Sub
Kode 2:
Private Sub
Worksheet_Change(ByVal Target As Range)
Dim myval As Long
On Error GoTo errhandler
Set myRange = Worksheets("Ark1").Range("B1:B100")
If Not Intersect(Target, Range("a1:a100")) Is Nothing Then
If UCase(Target.Value) = "X" Then
Target.Offset(0, 1).Value = Application.WorksheetFunction.Max(myRange) + 1
ElseIf Target.Value = "" Then
myval =
Target.Offset(0, 1).Value
Target.Offset(0, 1).Value = ""
For Each c In
Range("B1:B100").Cells
If c.Value <= myval Then
c.Value = c.Value
Else
c.Value = c.Value - 1
End If
Next
End If
End If
Exit Sub
errhandler:
If Err.Number = 13 Then
Worksheets("Ark1").Range("B1:B100").Clear
Exit Sub
End If
End Sub