Hej

Är det någon som har en snurra för att räkna
ut checksiffran i personnnr ?

Tack på förhand

Micke

- klippt från Excel, men kan säkert snabbt fixas till i VB

Option Explicit

Sub Kontroll()
Dim Pnr As String
Dim Testnr As String
Dim Kontrollsumma As Integer
Dim Subtotal As Integer
Dim resten As Integer
Dim kSiffra As Integer
Dim omr As Range
Dim I
Dim X As Integer
Dim persnr As String

Set omr = Application.Intersect(Range(ActiveCell.Address), Range("pnr"))
persnr = InputBox("Ange ditt personnummer")
Range("c8").Select
ActiveCell.Formula = persnr
If Not omr Is Nothing Then
Pnr = ActiveCell.Value
End If
If (Len(Pnr) <> 11 Or InStr(Pnr, "-") <> 7) Then
OgiltigtPnr (" Skriv i formatet 550101-0101")
End If
Testnr = Left(Pnr, 6) & Mid(Pnr, 8, 3)
Kontrollsumma = 0

For I = 1 To 9 Step 2
X = 2 * Val(Mid(Testnr, I, 1))
If X >= 10 Then
Subtotal = 1 + X - 10
Else
Subtotal = X
End If
Kontrollsumma = Kontrollsumma + Subtotal
Next I

For I = 2 To 8 Step 2
Subtotal = Val(Mid(Testnr, I, 1))
Kontrollsumma = Kontrollsumma + Subtotal
Next I
resten = Kontrollsumma Mod 10
If resten = 0 Then
kSiffra = 0
Else
kSiffra = 10 - resten
End If

If kSiffra <> Val(Right(Pnr, 1)) Then
OgiltigtPnr ("Kontrollsiffran räknades ut till " & Str(kSiffra))
End If
End Sub

VB variant:


<code>
Public Function CheckNumb(ByVal StrToCheck As String) As Boolean

'<-- Function to calculate and check integrity on a personal / organisation
'<-- number.
'<-- Returns true if valid number and false if not.
'<-- Input is a 10 digit number to be checked.

'<-- check lenght of string, if there is to few / many digits
'<-- raise an error back to the caller.

Dim sTemp As String, i As Integer
Dim bVar As Boolean, sum As Integer, temp As Integer

On Error GoTo errhandler

'<-- Chech the input and format it
If InStr(StrToCheck, "-") And Len(StrToCheck) = 11 Then
sTemp = Mid$(StrToCheck, 1, 6)
sTemp = sTemp & Mid$(StrToCheck, 8, 11)
StrToCheck = sTemp
ElseIf (Len(StrToCheck) <> 10) Or InStr(StrToCheck, "-") Then
CheckNumb = False
Exit Function
End If


'<-- Split the numbers up
'<-- and calculate them into a single sum.
'<-- Set a boolean flag to decide how to add the numbers
'<-- to the sum. should be 2x, 1x, 2x, 1x .. asf

For i = 1 To 9

If bVar Then
temp = CInt(Mid$(StrToCheck, i, 1))
bVar = Not bVar
Else
temp = 2 * CInt(Mid$(StrToCheck, i, 1))
bVar = Not bVar
End If

'<-- Check to see if the numbers calcualted was summed up to a number greater
'<-- then 10. In that case, split the numbers up.

If temp <= 9 Then
sum = sum + temp
Else
sum = ((sum + 1) + (temp - 10))
End If

Next i
sum = sum + CInt(Right$(StrToCheck, 1))


'<-- Divide the sum with 10 .. If nothing is left
'<-- number is valid.

CheckNumb = NOT ((sum Mod 10) > 0)

Exit Function
errhandler:
Call HandleError
End Function

</code>

Ytterliggare ett alternativ

Private Sub Command1_Click ()
Dim i As Integer
Dim summa As Integer, produkt As Integer, tal As Integer
Dim sträng As String
sträng = Text1.Text
For i = 1 To 10
tal = Val(Left(sträng, 1))
sträng = Right(sträng, (10 - i))
If i Mod 2 <> 0 Then
produkt = 2 * tal
If produkt > 9 Then
summa = summa + 1 + (produkt - 10)
Else
summa = summa + produkt
End If
Else
summa = summa + tal
End If
Next i
If summa Mod 10 = 0 Then
Text2.Text = "OK"
Else
Text2.Text = "Fel"
End If
End Sub