Automatisk ændring af tal i én kolonne

Det ville nok være en fordel at se regnearket.
Du er velkommen til at sende det til: pb@supertekst-it.dk

Hej Supertekst

Tak skal du ha' fil med ex er på vej

Ok - afventer...

Version 1:

Dim flag As Boolean, ptPrio
Private Sub Worksheet_Activate()
    flag = False
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim nyPrio, nyPrioRæk
On Error GoTo goon

    If Not Intersect(Target, Range("K:K")) Is Nothing Then
Rem Hvis x sættes i Kolonne K/11 & prioritet i denne række = 1 (kolonne C/3), så ophæv 1. prio & omnummerer
        If Target.Column = 11 And Target.Value = "x" And Target.Offset(0, -8) = 1 Then
            flag = True
            ophævPrio1 Target.Row
            flag = False
        End If
    Else
        If Not Intersect(Target, Range("C:C")) Is Nothing And flag = False Then
Rem ny numerisk værdi indtastes i kolonne C
            If Target.Value <> "" And IsNumeric(Target.Value) = True And flx = False Then
Rem Hvis prioritetsNr ændres
                flag = True
                nyPrio = Target.Value
                nyPrioRæk = Target.Row
                ændringAfPrio nyPrio, nyPrioRæk
                flag = False
            End If
            flag = False
        End If
    End If
    Exit Sub
   
goon:
End Sub
Private Sub ophævPrio1(prio1Række)
Dim ræk, startRæk
Rem fjern 1. prioritet og omnummerer (tæl een ned) indtil tom celle i kolonne A
    Cells(prio1Række, 3) = ""
   
    startRæk = findStartRække(prio1Række)
   
    If startRæk > 0 Then
        For ræk = startRæk + 1 To 65000
            If Cells(ræk, 3) <> "" And IsNumeric(Cells(ræk, 3)) = True Then
                Cells(ræk, 3) = Cells(ræk, 3) - 1
            Else
                If Cells(ræk, 1) = "" Then
                    Exit Sub
                End If
            End If
        Next ræk
    Else
        MsgBox ("Fejl nedlæg 1. prio. - startrække for prioriteter kunne ikke findes")
    End If
End Sub
Private Sub ændringAfPrio(xVærdi, xRække)
Dim ræk, startRæk, startværdi
    startRæk = findStartRække(xRække)
    startværdi = ptværdi
   
    If startRæk > 0 Then
        For ræk = startRæk + 1 To 65000
            If Cells(ræk, 3) <> "" And IsNumeric(Cells(ræk, 3)) = True Then
                If ræk <> xRække And Cells(ræk, 3) >= xVærdi Then
                    Cells(ræk, 3) = Cells(ræk, 3) + 1
                End If
            Else
                If Cells(ræk, 1) = "" Then
                    Exit Sub
                End If
            End If
        Next ræk
    Else
        MsgBox ("Fejl omnummerering - startrække for prioriteter kunne ikke findes")
    End If
End Sub
Private Function findStartRække(xRæk)
Dim ræk
Rem Find hvor prioriteterne begynder (led efter tom celle i kolonne A)
    For ræk = xRæk To 1 Step -1
        If Cells(ræk, 1) = "" Then
            findStartRække = ræk
            Exit Function
        End If
    Next ræk
    findStartRække = 0
End Function