Modtager et cprnr og afleverer en alder

På denne linie definerer du fødselsåret som 19 & fAar:

FoedselsDato = fDag & "-" & fMaaned & "-" & 19 & fAar '--------

Det skal vel ikke være sådan

Hej Mugs
Jeg kan ikke svare dig på, hvordan det skal være, da jeg ikke selv har, eller kan lave en sådan formel. Har du et bud på en løsning, er det meget velkomment.

Jeg har ike så maget tid lige nu (gæster), men i dette spørgsmål kan du finde en anden funktion, der beregner alderen:

http://eksperten.dk/spm/114681

Kunne ikke umiddelbart bruge det fra :http://eksperten.dk/spm/114681. Ville blive glad, hvis du kunne kigge på det senere!

CPR-nr indholder oplysninger om hvilket århundrede personen er født i....jeg laver lige en funktion til dig....

Indsæt disse 2 funktioner i et modul:

Function BeregnAlderFraCPR(CPR As String, Optional ByRef Køn As String) As Variant
'CPR kan angives både MED og UDEN bindestreg

On Error Resume Next
    Dim TestSum  As Long
    Dim Fødselsdato As Date
    Dim a As Integer, b As Integer, c As Integer, d As Integer, e As Integer, F As Integer, G As Integer, H As Integer, i As Integer, j As Integer
    Dim Aar As Integer, Mdr As Integer, Dag As Integer, Aarhundred As Integer
   
    'Fjern evt bindestreg
    CPR = Replace(CPR, "-", "")
   
    a = Mid(CPR, 1, 1)
    b = Mid(CPR, 2, 1)
    c = Mid(CPR, 3, 1)
    d = Mid(CPR, 4, 1)
    e = Mid(CPR, 5, 1)
    F = Mid(CPR, 6, 1)
    G = Mid(CPR, 7, 1)
    H = Mid(CPR, 8, 1)
    i = Mid(CPR, 9, 1)
    j = Mid(CPR, 10, 1)

    TestSum = (4 * a + 3 * b + 2 * c + 7 * d + 6 * e + 5 * F + 4 * G + 3 * H + 2 * i + j)
    If (TestSum Mod 11) <> 0 Then
        BeregnAlderFraCPR = Null
    End If
On Error GoTo Except
    'dag = StrToInt(cpr[1]+Cpr[2])
    Dag = Int(Mid(CPR, 1, 1) + Mid(CPR, 2, 1))
    'Mdr = StrToInt(cpr[3]+Cpr[4])
    Mdr = Int(Mid(CPR, 3, 1) + Mid(CPR, 4, 1))
    'Aar = StrToint(cpr[5]+Cpr[6])
    Aar = Int(Mid(CPR, 5, 1) + Mid(CPR, 6, 1))
    Aarhundred = 0
    Select Case G
        Case 0 To 3: Aarhundred = 1900
        Case 4
        Select Case Aar
            Case 0 To 36: Aarhundred = 1900
            Case 37 To 99: Aarhundred = 2000
        End Select
        Case 5
            Select Case Aar
                Case 0 To 36: Aarhundred = 2000
                Case 58 To 99: Aarhundred = 1800
            End Select
        Case 6
            Select Case Aar
                Case 0 To 36: Aarhundred = 2000
                Case 58 To 99: Aarhundred = 1800
            End Select
        Case 7
            Select Case Aar
                Case 0 To 36: Aarhundred = 2000
                Case 58 To 99: Aarhundred = 1800
            End Select
        Case 8
            Select Case Aar
                Case 0 To 36: Aarhundred = 2000
                Case 58 To 99: Aarhundred = 1800
            End Select
        Case 9
            Select Case Aar
                Case 0 To 36: Aarhundred = 2000
                Case 37 To 99: Aarhundred = 1900
            End Select
    End Select
    Fødselsdato = DateSerial(Aarhundred + Aar, Mdr, Dag)
    BeregnAlderFraCPR = Alder(Fødselsdato)
    Exit Function
Except:
    BeregnAlderFraCPR = Null

End Function

Public Function Alder(Dato As Date) As Integer
    If DateSerial(Year(Date), Month(Dato), Day(Dato)) > Date Then
        Alder = DateDiff("yyyy", Dato, Date) - 1
    Else
        Alder = DateDiff("yyyy", Dato, Date)
    End If
End Function


Herefter bruger du den bare således:

BeregnAlderFraCPR("0510025210")

Jeg har lige lavet den lidt mere elegant, så det hele ligger i én funktion (du behøver således ikke Alder-funktionen:

Function BeregnAlderFraCPR(CPR As String, Optional ByRef Køn As String) As Long
'CPR kan angives både MED og UDEN bindestreg

On Error Resume Next
    Dim TestSum  As Long
    Dim Fødselsdato As Date
    Dim a As Integer, b As Integer, c As Integer, d As Integer, e As Integer, F As Integer, G As Integer, H As Integer, i As Integer, j As Integer
    Dim Aar As Integer, Mdr As Integer, Dag As Integer, Aarhundred As Integer
   
    'Fjern eventuel bindestreg
    CPR = Replace(CPR, "-", "")
   
    a = Mid(CPR, 1, 1)
    b = Mid(CPR, 2, 1)
    c = Mid(CPR, 3, 1)
    d = Mid(CPR, 4, 1)
    e = Mid(CPR, 5, 1)
    F = Mid(CPR, 6, 1)
    G = Mid(CPR, 7, 1)
    H = Mid(CPR, 8, 1)
    i = Mid(CPR, 9, 1)
    j = Mid(CPR, 10, 1)

    TestSum = (4 * a + 3 * b + 2 * c + 7 * d + 6 * e + 5 * F + 4 * G + 3 * H + 2 * i + j)
   
    If (TestSum Mod 11) <> 0 Then
        MsgBox "CPR nr '" & CPR & "' er ugyldigt!"  'fjern denne linie, hvis der ikke ønskes en msgbox ved ugyldigt CPR
    End If
On Error GoTo Except
    'dag = StrToInt(cpr[1]+Cpr[2])
    Dag = Int(Mid(CPR, 1, 1) + Mid(CPR, 2, 1))
    'Mdr = StrToInt(cpr[3]+Cpr[4])
    Mdr = Int(Mid(CPR, 3, 1) + Mid(CPR, 4, 1))
    'Aar = StrToint(cpr[5]+Cpr[6])
    Aar = Int(Mid(CPR, 5, 1) + Mid(CPR, 6, 1))
    Aarhundred = 0
    Select Case G
        Case 0 To 3: Aarhundred = 1900
        Case 4
        Select Case Aar
            Case 0 To 36: Aarhundred = 1900
            Case 37 To 99: Aarhundred = 2000
        End Select
        Case 5
            Select Case Aar
                Case 0 To 36: Aarhundred = 2000
                Case 58 To 99: Aarhundred = 1800
            End Select
        Case 6
            Select Case Aar
                Case 0 To 36: Aarhundred = 2000
                Case 58 To 99: Aarhundred = 1800
            End Select
        Case 7
            Select Case Aar
                Case 0 To 36: Aarhundred = 2000
                Case 58 To 99: Aarhundred = 1800
            End Select
        Case 8
            Select Case Aar
                Case 0 To 36: Aarhundred = 2000
                Case 58 To 99: Aarhundred = 1800
            End Select
        Case 9
            Select Case Aar
                Case 0 To 36: Aarhundred = 2000
                Case 37 To 99: Aarhundred = 1900
            End Select
    End Select
    Fødselsdato = DateSerial(Aarhundred + Aar, Mdr, Dag)
    If DateSerial(Year(Date), Month(Fødselsdato), Day(Fødselsdato)) > Date Then
        BeregnAlderFraCPR = DateDiff("yyyy", Fødselsdato, Date) - 1
    Else
        BeregnAlderFraCPR = DateDiff("yyyy", Fødselsdato, Date)
    End If
    Exit Function
Except:
    BeregnAlderFraCPR = Null

End Function

hmm, endnu en lille skønhedsfejl (funktionen er videreudviklet fra en funktion)

Første linie kan bare se således ud:
Function BeregnAlderFraCPR(CPR As String) As Long

flot Thomas, men hvad bryger du køn til ?

se min kommentar herover :o)

Det var en anden funktion, som også kunne returnere køn'et

Ifølge denne funktion er jeg kun 2 år gammel. Men skal nok lige have set på det imorgen tidlig.

Nå - sugemallen kalder, mojn'

øh, hvad har du da tastet ind?

191050-xxxx

Når jeg taster det ind, så siger den 54 år

Ja det gør den også her nu - Jeg skulle lige have sendt CPRNR til modulet, og ikke det tal du havde skrevet i parantesen.

Godt, at der ikke er nogen, som siger "senil" *GG* :o)

Der er et lille problem i, at jeg har oprettet feltet på følgende måde: xxxxxx-xxxx men jeg bruger ikke de sidste fire -xxxx indtaster i stedet 0000. Thomas Jepsens forslag munder ud i en dialogboks med" cpr.nr xxxxxx-xxxx er ugyldigt. Kan det fixes?

"Jkrons" forslag i følgende tråd løser så vidt jeg kan se problemet http://www.eksperten.dk/spm/287575
Er der noget jeg skal tage højde for i den formel, eller kan jeg bruge den uden problemer?

Dit link refererer til et spørgsmål i Excel-kategorien. Nok "taler" både Excel og Access VBA, men der er sikkert nogle syntaksforskelle.

Det kontrolciffer som bestemmer i hvilket århundrede personen er født er det 7. ciffer i CPRNR:

7. ciffer    posttion 5 og 6  årstal
0-3          00-99            19xx
1            37-99            19xx
1            00-36            20xx
5-8          58-99            18xx
5-8          00-36            20xx
9            37-77            19xx
9            00-36            20xx

Kopieret fra en bog af Michell Cronberg fra forlaget Clobe.

Thomas > 75

Og det mugs skriver om findes faktisk på nettet: http://www.cpr.dk/imagesupload/dokument/Skema%20over%20personnummerets%20opbygning.pdf
Man kan ikke ud fra de første 6 cifre afgøre hvor gammel en person er.

Hej Mugs
Jeg havde ikke set det med Excel og Access. Vil det give nogle fejl, hvis jeg bruger det? Jeg har faktisk allerede gjort det, og umiddelbart er der ingen problemer.

Hvis der ikke er nogle problemer og alderen beregnes korrekt, er der vel ingen problemer i at bruge det. Men jeg har ikke så meget forstand på Excel. Du bør dog afprøve det meget nøje.

erikjacobsen > Dit link får min PC til at gå ned. Det ville ellers være interessant læsning. Jeg har læst et eller andet sted, at Indenrigsministeriet vil til at gå væk fra bl.a. modulus 11 beregningen. Så det ville være velkommen med en opdatering.

Det fungerer ikke helt optimalt, så jeg er stadig åben for gode råd/løsninger!!

thomasjepsen's løsning fungerer perfekt når du indtaster det fulde 10-cifrede CPRNR. Men som du kan se af ovenstående, skal du bruge det 7. ciffer for at bestemme i hvilket århundrede personen er født.

Desuden benytter thomasjepsen en modulus11 beregning for at kontrollere, om CPRNR er gyldigt.

Så hvis du vil benytte thomasjepsen's kode, er du nødt til at indtaste det 10-cifrede CPRNR.

Jeg ved ikke hvorfor linket ikke virker hos dig. Jeg har midlertidigt - uden at
spørge indenrigsministeríet om lov - lagt en kopi på http://test.n0p.com/personnummer.pdf

Virker den?

Det er downloadet og studeres nærmere imorgen - Tak

Jeg skal bruge det i en medlemsdatabase, hvor jeg ikke kan afkræve medlemmerne deres fulde cpr.nr. Kan der evt. rettes lidt i thomasjepsens formel, så den kan fungere uden indtastning i de sidste fire?

ribo, du kan fjerne min msgbox ved at fjerne den linie med msgbox'en (som beskrevet i kommentaren)

Her har jeg fjernet den for dig:

Function BeregnAlderFraCPR(CPR As String) As Long
'CPR kan angives både MED og UDEN bindestreg

On Error Resume Next
    Dim TestSum  As Long
    Dim Fødselsdato As Date
    Dim a As Integer, b As Integer, c As Integer, d As Integer, e As Integer, F As Integer, G As Integer, H As Integer, i As Integer, j As Integer
    Dim Aar As Integer, Mdr As Integer, Dag As Integer, Aarhundred As Integer
   
    'Fjern eventuel bindestreg
    CPR = Replace(CPR, "-", "")
   
    a = Mid(CPR, 1, 1)
    b = Mid(CPR, 2, 1)
    c = Mid(CPR, 3, 1)
    d = Mid(CPR, 4, 1)
    e = Mid(CPR, 5, 1)
    F = Mid(CPR, 6, 1)
    G = Mid(CPR, 7, 1)
    H = Mid(CPR, 8, 1)
    i = Mid(CPR, 9, 1)
    j = Mid(CPR, 10, 1)

    TestSum = (4 * a + 3 * b + 2 * c + 7 * d + 6 * e + 5 * F + 4 * G + 3 * H + 2 * i + j)
   
On Error GoTo Except
    'dag = StrToInt(cpr[1]+Cpr[2])
    Dag = Int(Mid(CPR, 1, 1) + Mid(CPR, 2, 1))
    'Mdr = StrToInt(cpr[3]+Cpr[4])
    Mdr = Int(Mid(CPR, 3, 1) + Mid(CPR, 4, 1))
    'Aar = StrToint(cpr[5]+Cpr[6])
    Aar = Int(Mid(CPR, 5, 1) + Mid(CPR, 6, 1))
    Aarhundred = 0
    Select Case G
        Case 0 To 3: Aarhundred = 1900
        Case 4
        Select Case Aar
            Case 0 To 36: Aarhundred = 1900
            Case 37 To 99: Aarhundred = 2000
        End Select
        Case 5
            Select Case Aar
                Case 0 To 36: Aarhundred = 2000
                Case 58 To 99: Aarhundred = 1800
            End Select
        Case 6
            Select Case Aar
                Case 0 To 36: Aarhundred = 2000
                Case 58 To 99: Aarhundred = 1800
            End Select
        Case 7
            Select Case Aar
                Case 0 To 36: Aarhundred = 2000
                Case 58 To 99: Aarhundred = 1800
            End Select
        Case 8
            Select Case Aar
                Case 0 To 36: Aarhundred = 2000
                Case 58 To 99: Aarhundred = 1800
            End Select
        Case 9
            Select Case Aar
                Case 0 To 36: Aarhundred = 2000
                Case 37 To 99: Aarhundred = 1900
            End Select
    End Select
    Fødselsdato = DateSerial(Aarhundred + Aar, Mdr, Dag)
    If DateSerial(Year(Date), Month(Fødselsdato), Day(Fødselsdato)) > Date Then
        BeregnAlderFraCPR = DateDiff("yyyy", Fødselsdato, Date) - 1
    Else
        BeregnAlderFraCPR = DateDiff("yyyy", Fødselsdato, Date)
    End If
    Exit Function
Except:
    BeregnAlderFraCPR = Null

End Function


Med hensyn til at få den til at fungere uden de sidste 4 cifre, så kan det jo ikke lade sig gøre, da man så ikke ved hvilket århundrede, vi snakker om.

"kan det jo ikke lade sig gøre" - men det kan, hvis vi antager at ingen er over 100 år.

Men Ribo, hvis du slet ikke bruger CPR, men blot indtaster deres fødselsdato, hvorfor indtaster du det så ikke bare i datoformat (med 4-cifret årstal) og derfter blot bruger min anden Alder-funktion:

Public Function Alder(Dato As Date) As Integer
    If DateSerial(Year(Date), Month(Dato), Day(Dato)) > Date Then
        Alder = DateDiff("yyyy", Dato, Date) - 1
    Else
        Alder = DateDiff("yyyy", Dato, Date)
    End If
End Function

erikjacobsen > korrekt, hvis ribo's database skal bruges i en fodboldklub for ynglinge er det OK. Men hvis det er en klub for medlemmer af "De Gamles hjem's" peddigrørsforening holder den ikke i længden.

Problemet er, hvis det da er noget problem, at jeg har en Access database med over 450 navne og fødselsdatoer. Feltet med cpr nr. er xxxxxx-xxxx hvor jeg ikke bruger de sidste fire cifre (indtastes med -0000). Jeg har først for nylig opdaget, at funktionen til at finde medlemmer under 25 år ikke virkede helt efter hensigten (kunne ikke finde dem der er født i og efter 2000). Hvad har jeg af muligheder for at få thomasjepsens forslag til at virke? Skal jeg evt ind og rette i tabellen og kan det gøres uden de store problemer?

Har du læst mine sidste indlæg? Den sidste udgave af funktionen, som jeg lagde ind (uden msgbox) skulle kunne klare dit problem

Betyder det at jeg kan indtaste -0000 og alligevel få de rigtige data? Har lige forsøgt mig, og det ser sørme ud til at fungere. Jeg havde ellers fået opfattelsen af, at der skulle være indtastet de sidste fire cifre af cpr nummeret før det ville fungere.

Det skulle virke - bortset fra, at den vil betragte 010101-0000 som værende 104 år i stedet for 4.
Hvilken regel vil du benytte, når du ikke har de sidste 4 cifre?
Man kan ret let løse problemet ved at sige, at man ikke "kan" være over 100 år

Nej, det duer ikke!
Jeg skal bruge denne beregning i en forespørgsel, hvor jeg ved hjælp af <25 skal kunne udvælge alle under 25 år også gældende dem der er født i og efter 2000

ja, men så er du stadig nødt til at lave reglen om at folk ikke kan være over 100 år. Prøv denne kode:

Function BeregnAlderFraCPR(CPR As String) As Long
'CPR kan angives både MED og UDEN bindestreg

On Error Resume Next
    Dim TestSum  As Long
    Dim Fødselsdato As Date
    Dim a As Integer, b As Integer, c As Integer, d As Integer, e As Integer, F As Integer, G As Integer, H As Integer, i As Integer, j As Integer
    Dim Aar As Integer, Mdr As Integer, Dag As Integer, Aarhundred As Integer
   
    'Fjern eventuel bindestreg
    CPR = Replace(CPR, "-", "")
   
    a = Mid(CPR, 1, 1)
    b = Mid(CPR, 2, 1)
    c = Mid(CPR, 3, 1)
    d = Mid(CPR, 4, 1)
    e = Mid(CPR, 5, 1)
    F = Mid(CPR, 6, 1)
    G = Mid(CPR, 7, 1)
    H = Mid(CPR, 8, 1)
    i = Mid(CPR, 9, 1)
    j = Mid(CPR, 10, 1)

'    TestSum = (4 * a + 3 * b + 2 * c + 7 * d + 6 * e + 5 * F + 4 * G + 3 * H + 2 * i + j)
   
'    If (TestSum Mod 11) <> 0 Then
'        MsgBox "CPR nr '" & CPR & "' er ugyldigt!"  'fjern denne linie, hvis der ikke ønskes en msgbox ved ugyldigt CPR - f.eks. ved brug i forespørgsler m.m.
'    End If
On Error GoTo Except
    Dag = Int(Mid(CPR, 1, 1) + Mid(CPR, 2, 1))
    Mdr = Int(Mid(CPR, 3, 1) + Mid(CPR, 4, 1))
    Aar = Int(Mid(CPR, 5, 1) + Mid(CPR, 6, 1))
    Aarhundred = 0
    Select Case G
        Case 0 To 3: Aarhundred = 1900
        Case 4
        Select Case Aar
            Case 0 To 36: Aarhundred = 1900
            Case 37 To 99: Aarhundred = 2000
        End Select
        Case 5
            Select Case Aar
                Case 0 To 36: Aarhundred = 2000
                Case 58 To 99: Aarhundred = 1800
            End Select
        Case 6
            Select Case Aar
                Case 0 To 36: Aarhundred = 2000
                Case 58 To 99: Aarhundred = 1800
            End Select
        Case 7
            Select Case Aar
                Case 0 To 36: Aarhundred = 2000
                Case 58 To 99: Aarhundred = 1800
            End Select
        Case 8
            Select Case Aar
                Case 0 To 36: Aarhundred = 2000
                Case 58 To 99: Aarhundred = 1800
            End Select
        Case 9
            Select Case Aar
                Case 0 To 36: Aarhundred = 2000
                Case 37 To 99: Aarhundred = 1900
            End Select
    End Select

    'Find fødselsdagen
    If Right(CPR, 4) = "0000" Then
        If Aar > Val(Format(Year(Date), "yy")) Then
            Fødselsdato = DateSerial(Aarhundred + Aar, Mdr, Dag)
        Else
            Fødselsdato = DateSerial(Aarhundred + 100 + Aar, Mdr, Dag)
        End If
    Else
        Fødselsdato = DateSerial(Aarhundred + Aar, Mdr, Dag)
    End If
    'Find alderen
    If DateSerial(Year(Date), Mdr, Dag) > Date Then
        BeregnAlderFraCPR = DateDiff("yyyy", Fødselsdato, Date) - 1
    Else
        BeregnAlderFraCPR = DateDiff("yyyy", Fødselsdato, Date)
    End If
    Exit Function
Except:
    BeregnAlderFraCPR = Null

End Function




Lav derefter et nyt felt i din forespørgsel:

Alder: BeregnAlderFraCPR([CPRnr])
og sæt kriteriet til <25

Nu ser det ud til at virke efter hensigten! Puha!
tak til jer alle og specielt thomasjepsen for din udholdenhed

Bare godt, at du fik det til at virke :o)

takker :o)

Fin funktion, har taget den i anvendelse :o)

Her er Modulus-11 testen der ser efter om et cprnummer er gyldigt, så er der jo samling på tingene :o)

Public Function CPRnummer(CPR As String) As Boolean

' Modulus-11 kontrol på et Cpr-nummer
' Cpr-nummer:  1  3  0  5  6  6  -  2  4  1  7
' Kontrol tal:  4  3  2  7  6  5    4  3  2  1
' Gange lodret: 4  9  0 35 36 30    8 12  2  7 = 143
' 143 divideres med 11 (143/11) = 13 og ingen rest, er det samme som 143 mod 11 = 0
' Når man får rest/mod = 0 er Cpr-nummer korrekt

Dim cprcheck As String
Dim rest As Integer
Dim i As Integer
Dim sum As Integer
Dim datox As Variant
Dim kontrol As Integer
Dim Aar As Integer

'Starter med kontrol af datoen i cpr-nuummer ved først at få fat i datoen inkl.
'hvilket århundrede

kontrol = CInt(Mid$(CPR, 8, 4)) 'de sidste 4 cifre i CPR-nummer
Aar = CInt(Mid$(CPR, 5, 2))

If kontrol < 5000 Then          'ulige århundrede f.eks. 1900 og 2100
    datox = Mid$(CPR, 1, 2) & "-" & Mid$(CPR, 3, 2) & "-19" & Mid$(CPR, 5, 2)
ElseIf Aar > 70 Then
        datox = Mid$(CPR, 1, 2) & "-" & Mid$(CPR, 3, 2) & "-18" & Mid$(CPR, 5, 2)
    Else
    datox = Mid$(CPR, 1, 2) & "-" & Mid$(CPR, 3, 2) & "-20" & Mid$(CPR, 5, 2)
End If

If IsDate(datox) Then          'kontrol for at datoen i cpr er korrekt
   
    If DateValue(datox) <= Date Then
        cprcheck = "432765-4321" 'den normale cpr-nummer kontrol
        sum = 0
        For i = 1 To 11
            If Mid$(CPR, i, 1) <> "-" Then
                sum = sum + CInt(Mid$(CPR, i, 1)) * CInt(Mid$(cprcheck, i, 1))
            End If
        Next i
        rest = sum Mod 11
        If rest = 0 Then
            CPRnummer = True
        Else
            CPRnummer = False
        End If
    Else
    CPRnummer = False
    End If
Else
    CPRnummer = False
End If

End Function