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

 

- Tilbage til makroer -
- Tilbage til Excel -