• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Kentekens aanpassen d.m.v. VBA

Status
Niet open voor verdere reacties.
fun_surfer

fun_surfer

Gebruiker
Lid geworden
25 aug 2001
Berichten
621
Hallo allemaal, voor mijn werk heb ik een lijst met kentekens die ik dagelijks moet bijwerken. Nu wil ik kunnen volstaan door alleen de 6 tekens in te vullen en d.m.v. een macro dit automatisch om laten zetten in kentekens met hoofdletters. Ik heb al een soortgelijke macro voor de tijd (onderstaand), als ik 1115 invul wordt dit automatisch 11:15. Kan ik dit zonder al te veel problemen samen laten werken en zo ja, welke aanpassing moet ik doen?
Alvast bedankt, groeten Art.

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Intersect(Target, Range("E7:K9")) Is Nothing Then GoTo Einde
    If IsEmpty(Target) Then GoTo Einde
    If Hour(Target.Value) <> 0 Or Minute(Target.Value) <> 0 Then GoTo Einde
    Application.EnableEvents = False
    If Int(Target.Value / 100) < 0.1 Then
        Target = "00:" & Target.Value
        Else
        Target = Int(Target.Value / 100) & ":" & Right(Target.Value, 2)
    End If
    Application.EnableEvents = True
Einde:
    ActiveSheet.Calculate
End Sub
 
fun_surfer zei:
een lijst met kentekens die ik dagelijks moet bijwerken. Nu wil ik kunnen volstaan door alleen de 6 tekens in te vullen en d.m.v. een macro dit automatisch om laten zetten in kentekens met hoofdletters.
Klik om te vergroten...

Kan je een voorbeeld geven van een typisch kenteken en wat het resultaat zou moeten zijn voor dit kenteken? Werkt gemakkelijker.
 
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, Range("E7:K9")) Is Nothing Then GoTo Einde

If IsEmpty(Target) Then GoTo Einde

If IsNumeric(Target) = True Then
If Hour(Target.Value) <> 0 Or Minute(Target.Value) <> 0 Then GoTo Einde
Application.EnableEvents = False
If Int(Target.Value / 100) < 0.1 Then
Target = "00:" & Target.Value
Else
Target = Int(Target.Value / 100) & ":" & Right(Target.Value, 2)
End If
Else
If Len(Target) = 6 Then
Target = UCase(Left(Target, 2) & "-" & Mid(Target, 3, 2) & "-" & Right(Target, 2))
End If
End If
Application.EnableEvents = True
Einde:
ActiveSheet.Calculate
End Sub
 
Laatst bewerkt:
Als je dit bedoeld 34-DR-VY kun dit gebruiken :

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
Application.EnableEvents = False
Target = Left(Target, 2) & "-" & Mid(Target, 3, 2) & "-" & Right(Target, 2)
Application.EnableEvents = True
End If
End Sub

Dit is wel voor kolom A.

Met dank aan IngridB.

Pierre
 
Laatst bewerkt:
Hallo allemaal, sorry voor de late reactie, ik ben weer een weekje weg geweest voor mijn werk.
Ik was vergeten te melden dat de kentekens in de rij E19:K19 staan. Ik heb uit jullie oplossingen dus de volgende code gecreëerd en deze werkt:
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Intersect(Target, Range("E7:K9")) Is Nothing Then GoTo Kenteken
    If IsEmpty(Target) Then GoTo Kenteken
    If Hour(Target.Value) <> 0 Or Minute(Target.Value) <> 0 Then GoTo Kenteken
    Application.EnableEvents = False
    If Int(Target.Value / 100) < 0.1 Then
        Target = "00:" & Target.Value
        Else
        Target = Int(Target.Value / 100) & ":" & Right(Target.Value, 2)
    End If
    Application.EnableEvents = True
Kenteken:
    If Intersect(Target, Range("E19:K19")) Is Nothing Then GoTo Einde
    If Len(Target) = 6 Then
    Target = UCase(Left(Target, 2) & "-" & Mid(Target, 3, 2) & "-" & Right(Target, 2))
    End If
Einde:
    ActiveSheet.Calculate
End Sub
Hij doet het en het is dus volgens mij goed, of zie ik toch iets over het hoofd?
Allemaal bedankt, groeten Art.
 
Is het ook mogelijk om de eerste letter van weer een ander bereik als hoofdletter neer te zetten? Bijv. de ene keer 'marco' in 'Marco' en bijv. 'mart' in 'Mart'. GRTZ Art.
 
Via onderstaande macro wordt de beginletter van de waardes in het cellenbereik A1 t/m A10 voorzien van een hoofdletter.

Sub Macro1()
Dim Rij As Integer
For Rij = 1 To 10
Cells(Rij, "A") = Application.WorksheetFunction.Proper(Cells(Rij, "A"))
Next
End Sub
 
Beste Roncancio, bedankt voor je reactie. Ik heb geprobeerd je macro tussen te voegen in de private sub, maar ik geloof dat hij dan in een loop komt. Mijn kennis rijkt blijkbaar niet zo ver dat ik dit foutloos kan doen. Wat doe ik fout en wat geberut er met de onderstaande macro?
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Intersect(Target, Range("E7:K9")) Is Nothing Then GoTo Kenteken
    If IsEmpty(Target) Then GoTo Kenteken
    If Hour(Target.Value) <> 0 Or Minute(Target.Value) <> 0 Then GoTo Kenteken
    Application.EnableEvents = False
    If Int(Target.Value / 100) < 0.1 Then
        Target = "00:" & Target.Value
        Else
        Target = Int(Target.Value / 100) & ":" & Right(Target.Value, 2)
    End If
    Application.EnableEvents = True
Kenteken:
    If Intersect(Target, Range("E19:K19")) Is Nothing Then GoTo Hoofdletter
    If Len(Target) = 6 Then
    Target = UCase(Left(Target, 2) & "-" & Mid(Target, 3, 2) & "-" & Right(Target, 2))
    End If
Hoofdletter:
    If Intersect(Target, Range("E13:K17")) Is Nothing Then GoTo Einde
    Dim Rij As Integer
    For Rij = 13 To 17
    Cells(Rij, "E") = Application.WorksheetFunction.Proper(Cells(Rij, "E"))
    Cells(Rij, "F") = Application.WorksheetFunction.Proper(Cells(Rij, "F"))
    Cells(Rij, "G") = Application.WorksheetFunction.Proper(Cells(Rij, "G"))
    Cells(Rij, "H") = Application.WorksheetFunction.Proper(Cells(Rij, "H"))
    Cells(Rij, "I") = Application.WorksheetFunction.Proper(Cells(Rij, "I"))
    Cells(Rij, "J") = Application.WorksheetFunction.Proper(Cells(Rij, "J"))
    Cells(Rij, "K") = Application.WorksheetFunction.Proper(Cells(Rij, "K"))
    Next
Einde:
    ActiveSheet.Calculate
End Sub
Groeten Art.
EDIT: P.S.: Ik ben weer een paar dagen naar het buitenland en kom hier dus niet direct op terug...
 
Laatst bewerkt:
fun_surfer zei:
Beste Roncancio, bedankt voor je reactie. Ik heb geprobeerd je macro tussen te voegen in de private sub, maar ik geloof dat hij dan in een loop komt. Mijn kennis rijkt blijkbaar niet zo ver dat ik dit foutloos kan doen. Wat doe ik fout en wat geberut er met de onderstaande macro?
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
End Sub
Klik om te vergroten...

Dat de macro in een loop komt is niet zo erg maar het probleem was dat het een oneindige loop is.

Je probleem is heel simpel op te lossen door de code te verplaatsen naar een ander event.
De macro wordt nu gestart als er iets in het werkblad is gewijzigd. Doordat je via de macro de beginletters in hoofdletters zet, wijzigt dus je werkblad en wordt de macro dus steeds opnieuw gestart.
Zet de code in de Sub Selection_Change en de macro wordt geactiveerd als je de cursor verplaatst.
Verder heb ik de macro wat aangepast en iets korter gemaakt.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, Range("E7:K9")) Is Nothing Then GoTo Kenteken
If IsEmpty(Target) Then GoTo Kenteken
If Hour(Target.Value) <> 0 Or Minute(Target.Value) <> 0 Then GoTo Kenteken
Application.EnableEvents = False
If Int(Target.Value / 100) < 0.1 Then
Target = "00:" & Target.Value
Else
Target = Int(Target.Value / 100) & ":" & Right(Target.Value, 2)
End If
Application.EnableEvents = True
Kenteken:
If Intersect(Target, Range("E19:K19")) Is Nothing Then GoTo Hoofdletter
If Len(Target) = 6 Then
Target = UCase(Left(Target, 2) & "-" & Mid(Target, 3, 2) & "-" & Right(Target, 2))
End If
Hoofdletter:
Dim Rij, Kolom As Integer
If Target.Row >= 13 And Target.Row <= 17 And Target.Column >= 5 And Target.Column <= 11 Then
For Rij = 13 To 17
For Kolom = 5 To 11
Cells(Rij, Kolom) = Application.WorksheetFunction.Proper(Cells(Rij, Kolom))
Next
Next
End If
Einde:
ActiveSheet.Calculate

End Sub
 
Roncancio, bedankt voor de uitleg en de code, nu je het zo stelt is het eigenlijk zo simpel dat ik me een beetje schaam dat ik hier zelf niet aan heb gedacht... :o Ik begrijp alleen het volgende gedeelte nog niet:
Cells(Rij, Kolom) = Application.WorksheetFunction.Proper(Cells(Rij, Kolom))
Waar is dit voor? Zoals je waarschijnlijk al wist werkt hij overigens perfect, nogmaals bedankt! GRTZ Art.
 
fun_surfer zei:
Cells(Rij, Kolom) = Application.WorksheetFunction.Proper(Cells(Rij, Kolom))
Waar is dit voor?
Klik om te vergroten...

Met VBA kun je een aantal functies die er in Excel staan, gebruiken.

Bijv.
Stel dat je het maximum wilt hebben van het bereik B1 tm B10 en het resultaat zet je in A1 neer.
Dan gebruik je:
[A1] = Application.WorksheetFunction.Max(Range("B1:b10"))


Met Application.WorksheetFunction.Proper zet je de beginletter van de tekst in een cel om in een hoofdletter.

Stel in A1 staat excel
Via

[A1] = Application.WorksheetFunction.Proper(Range("A1"))

...staat er nu Excel
 
Okéé, bedankt voor de uitleg; als ik het goed begrijp is dat dus de eigenlijke actie voor de 'triggercel' binnen het aangegeven bereik. Weer wat geleerd. Zoals gezegd ben ik nog niet erg (lees: erg niet) thuis in VBA, maar zo iedere keer leer ik weer wat.
Bedankt en tot de volgende vraag, Art.
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan