Celnotatie tekst

[hoogteijling]

Hallo allemaal,

In een cel staat de notatie op TEKST ingesteld.
Voorheen had ik de celnotatie op aangepast staan [<=9999]0"."000;0"."0"."000 maar dat kan nu niet meer.

In die cel wordt een 4- of 5-cijferig nummer ingevuld.
Bijv: 1.234 of 1.2.345

Is het mogelijk dat ik alleen de getallen invul en dat de puntjes automatisch ingevuld worden net zoals bij de aangepaste celnotatie ?

Groeten Marcel

 

[ExcelAmateur]

Marcel,

Kijk of je hier wat aan heeft.

 

[hoogteijling]

Dit ziet er veel belovend uit.
Ik ga dit binnenkort in mijn sheet toepassen en kijken of het werkt.

Groeten Marcel

 

[hoogteijling]

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = 3 Then
  If Mid(Target, 2, 1) = "." Then Exit Sub
    Select Case Len(Target)
      Case 4
        Target = Left(Target, 1) & "." & Right(Target, 3)
        Exit Sub
      Case 5
        Target = Left(Target, 1) & "." & Mid(Target, 2, 1) & "." & Right(Target, 3)
    End Select
  End If
End Sub

Voor jouw vast heel simpel om de code zo aan te passen dat het alleen voor de cellen A10 t/m A21 geldt.

Groeten Marcel

 

[HSV]

Omdat de celopmaak eenmaal op tekst heeft gestaan krijg je het moeilijk terug op een ander opmaak.
Met deze code kan je doorrekenen, daar de opmaak aangepast wordt als voorheen in plaats van punten toegevoegd.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Application.EnableEvents = False
  If Not Intersect(Target, Range("A10:A21")) Is Nothing Then
  If Not IsEmpty(Target) Then
   If IsNumeric(Target) Then
      Target = Target * 1
    Select Case Len(Target)
        Case 4, 5
       Target.NumberFormat = "[<=9999]0"".""000;0"".""0"".""000"
    End Select
    End If
   End If
  End If
  Application.EnableEvents = True
End Sub

 

[hoogteijling]

Dank je Hsv voor de toevoeging,
de opmaak moet op tekst blijven staan omdat andere excelbestanden gegevens uit dit bestand halen en daardoor niet meer goed werken als de opmaak niet op tekst staat.

Maar toch een handig stukje code wat ik later misschien nog wel kan gebruiken.

Groeten Marcel

 

[HSV]

Als je zeker weet dat de opmaak op tekst staat Marcel.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Application.EnableEvents = False
  If Not Intersect(Target, Range("A10:A21")) Is Nothing Then
  If Not IsEmpty(Target) Then
   If IsNumeric(Target) Then
    Select Case Len(Target)
      Case 4
         Target.Characters(2, 0).Insert (".")
      Case 5
       For i = 1 To 2
         Target.Characters(2 * i, 0).Insert (".")
       Next i
     End Select
    End If
   End If
  End If
Application.EnableEvents = True
End Sub

 

[hoogteijling]

Ze hebben besloten de projectnummer notatie aan te passen.
Het is nu voortaan 1.234 of 1.234-0.
De eerdere code werkt wel behalve als iemand zo eigenwijs is om wel handmatig een puntje in te typen.

Kan iemand de code aanpassen zodat dat ook gaat werken ?

Groeten Marcel

 

[HSV]

Test het nog maar eens dan Marcel.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Application.EnableEvents = False
  If Not Intersect(Target, Range("A10:A21")) Is Nothing Then
  If Not IsEmpty(Target) Then
   If IsNumeric(Target) Then
   Target.NumberFormat = "@"
   Target = Replace(Replace(Target, ",", ""), "-", "")
    Select Case Len(Target)
      Case 4
         Target.Characters(2, 0).Insert (".")
      Case 5
         Target.Characters(2, 0).Insert (".")
         Target.Characters(6, 0).Insert ("-")
     End Select
    End If
   End If
  End If
Application.EnableEvents = True
End Sub

 

[hoogteijling]

Bedankt HSV,
Deze code werkt goed.
Ik zou nu willen voorkomen dat wanneer iemand handmatig een puntje of een streepje invult dat het dan misgaat, want dat is nu het geval.
Is dat mogelijk of kan dat niet ?
Of misschien dat er automatisch een puntje verschijnt na het intypen van het eerste getal.

Groeten Marcel

 

[HSV]

Of:

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
  If Not Intersect(Target, Range("A10:A21")) Is Nothing Then
  If Not IsEmpty(Target) And Selection.Count = 1 Then
   Target.NumberFormat = "@"
   Target = Replace(Replace(Target, ",", ""), "-", "")
    Select Case Len(Target)
      Case 4
         Target.Characters(2, 0).Insert (".")
      Case 5
         Target.Characters(2, 0).Insert (".")
         Target.Characters(6, 0).Insert ("-")
      Case Else
         MsgBox "Je hebt geen 4 of 5 cijferig getal ingevoerd", vbCritical, "Beetje opletten!"
         Application.Goto Target
         Target.ClearContents
     End Select
   End If
  End If
Application.EnableEvents = True
End Sub

 

[hoogteijling]

Ik kan hier mee uit de voeten.
Bedankt allemaal.

Groeten Marcel

 

[hoogteijling]

Uiteindelijk blijkt dat we alleen verder gaan met de volgende notatie 1.234.
Code heb ik aangepast naar:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Application.EnableEvents = False
  If Not Intersect(Target, Range("A10:A21")) Is Nothing Then
  If Not IsEmpty(Target) Then
   If IsNumeric(Target) Then
    Select Case Len(Target)
      Case 4
         Target.Characters(2, 0).Insert (".")
     End Select
    End If
   End If
  End If
Application.EnableEvents = True
End Sub

Deze werkt uitstekend voor mijn doel.
ExcelAmateur en HSV bedankt voor jullie inbreng. :thumb:

Groeten Marcel