volgnummer

[popipipo]

In kolom A staan namen
in kolom B zet ik een vinkje (dubbel klikken)
in kolom C wil ik nu een volgnummer

Achter het eerste vinkje dat gezet wordt komt een 1 achter het 2e een 2 enz.
De vinkjes worden in willekeurige volgorde in kolom B gezet.

Foutjes die afgevangen moeten worden:

- Als je een vinkje weghaalt (nogmaals dubbel klikken) moet het volgnr verdwijnen, er ontstaat een hiaat in de nummering, dit hiaat moet opgevuld worden door het plaatsen van het eerst volgende vinkje.

- Het bestand moet bij op nieuw openen gewoon verder gaan, maar dmv een reset button o.i.d. moet kolom B en C gewist worden en de telling opnieuw beginnen.

 

[Cobbe]

Niet volledig foutvrij(denk ik ) maar toch een grote stap in de goede richting.

 

[HSV]

Of:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Range("b1:b100")) Is Nothing Then
With Target
   If .Value = "" Then
             .Value = "P"
             .Font.Name = "Wingdings 2"
             .Offset(, 1) = [Max(c1:c100)] + 1
    Else
             .Value = ""
             .Font.Name = "calibri"
             .Offset(, 1).ClearContents
    End If
          Application.Goto .Offset(1)
       End With
     Cancel = True
   End If
End Sub

 

[Cobbe]

En hoe haal je nu de ontbrekende nummers (na verwijdering van vinkje) op?

 

[HSV]

Als die vraag aan mij gericht is Cobbe.
Door te dubbelklikken in de cel haal ik het vinkje weg, en daarmee het nummer.
Zet ergens anders een vinkje neer.... klaar lijkt me.

 

[Cobbe]

Och het was meer een bedenking.

Maar de bedoeling was om de reeds gegeven nummering intact te laten en als er een vinkje weggehaald wordt dat dat nummer als eerste weer gegeven wordt bij een nieuw vinkje.

Snappie?

 

[HSV]

Mis ik dan ergens iets Cobbe?

Foutjes die afgevangen moeten worden:

- Als je een vinkje weghaalt (nogmaals dubbel klikken) moet het volgnr verdwijnen, er ontstaat een hiaat in de nummering, dit hiaat moet opgevuld worden door het plaatsen van het eerst volgende vinkje.

 

[popipipo]

Ik zie net dat harry gereageerd heeft en nog niet zijn reactie bekeken

@cobbe
VindOntbrekendGetal()
Hij moest alleen nog gereset worden want hij bleef ontbrekend getal invullen:

Sub VindOntbrekendGetal()

    Dim rCell As Range
    Dim rToSeek As Range
    Dim i As Integer
  [COLOR="#FF0000"]  ontbreek = 0[/COLOR]
    Set rToSeek = Intersect(Columns(3), ActiveSheet.UsedRange)
   
    For i = 1 To WorksheetFunction.Max(rToSeek)
        Set rCell = rToSeek.Find(what:=i, lookat:=xlWhole, LookIn:=xlValues)
          If rCell Is Nothing Then
            ontbreek = i
        End If
    Next

End Sub

 

[HSV]

Zo kan je alleen maar verwijderen met een dubbelklik, en niet meer handmatig in B1:C100.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 Application.EnableEvents = False
    If Not Intersect(Target, Range("b1:b100")) Is Nothing Then
With Target
   If .Value = "" Then
             .Value = "P"
             .Font.Name = "Wingdings 2"
             .Offset(, 1) = [Max(c1:c100)] + 1
    Else
             .Value = ""
             .Font.Name = "calibri"
             .Offset(, 1).ClearContents
    End If
          Application.Goto .Offset(1)
       End With
     Cancel = True
   End If
 Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
With Application
   .EnableEvents = False
If Not Intersect(Target, Range("B1:C100")) Is Nothing Then .Undo
    .EnableEvents = True
    End With
End Sub

Moet nu weg, kijk vanavond wel even weer.

 

[Cobbe]

Ja sorry, had ik overzien.

Maar ook de resetknop heb ik niet gemaakt maar eerst de koers kijken hé.

 

[popipipo]

@harry

Je bestandje werkt goed als je de laatste invoer weg haalt
Maar haal je tussendoor een nummer weg dan vul hij deze niet aan en je krijg dus een hiaat in de nummering.

 

[popipipo]

Dit is het voorlopig geworden.

Opmerkingen zijn altijd welkom

 

[snb]

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   If Target.Count = 1 And Target.Column = 2 Then

      Target.Value = IIf(Target.Value = "P", "", "P")
      Target.Offset(, 1) = ""

      If Target.Value = "P" Then
        For j = 1 To Application.CountIf(Range("B1:B100"), "P")
          If IsError(Application.Match(j, Range("C1:C100"), 0)) Then
            Target.Offset(, 1) = j
            Exit For
          End If
        Next
        If j = Application.CountIf(Range("B1:B100"), "P") Then Target.Offset(, 1).Value = j
      End If

      Cancel = True
    End If
End Sub

 

[JeanPaul28]

Zou deze oplossing je bedoeling zijn

 

[popipipo]

Ik zet de vraag snel op opgelost want ik heb nu al een stuk of 3 goede oplossingen.
Allen hartelijk dank voor uw inzet :thumb: