Hvis formel med inddeling

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("B:B")) Is Nothing Then
        Dim ws As Worksheet: Set ws = ActiveSheet
        Dim rCol As Range, rCell As Range
        Set rCol = ws.Range("B:B")
        For Each rCell In rCol
            If rCell.Offset(0, -1) = Null Then Exit Sub
            Select Case rCell.Value
                Case 1000 To 1999
                    rCell.Offset(0, 1).Value = "1000-1999"
                Case 2000 To 2999
                    rCell.Offset(0, 1).Value = "2000-2999"
                Case 3000 To 3999
                    rCell.Offset(0, 1).Value = "3000-3999"
                Case 4000 To 4999
                    rCell.Offset(0, 1).Value = "4000-4999"
                Case 5000 To 5999
                    rCell.Offset(0, 1).Value = "5000-5999"
                Case 6000 To 6999
                    rCell.Offset(0, 1).Value = "6000-6999"
                Case 7000 To 7999
                    rCell.Offset(0, 1).Value = "7000-7999"
                Case 8000 To 8999
                    rCell.Offset(0, 1).Value = "8000-8999"
                Case 9000 To 9999
                    rCell.Offset(0, 1).Value = "9000-9999"
                Case Else
                    rCell.Offset(0, 1).Value = ""
            End Select
        Next
    End If
End Sub