Hej

Har ett script för validera ett personnummer i en enskild "ruta", hur gör jag för att i exel kunna validera tex. dom nummer som står kolum A i kolumn B med Sant eller Falskt ?

Private Sub Personnummer()
Dim StrRaknare, NamnStr As String, Int1 As Integer, Resultat2, Resultat1 As Integer
Dim b, i As Integer, Int2 As Integer, Siffra As Integer

StrRaknare = ""
Int1 = 0
Int2 = 0
Siffra = 0
NamnStr = Left([Personnummer], 6) & Right([Personnummer], 4)

For b = 1 To Len(NamnStr)
Siffra = Mid(NamnStr, b, 1)
Select Case b
Case 1
StrRaknare = StrRaknare & (Siffra * 2)
Case 3
StrRaknare = StrRaknare & (Siffra * 2)
Case 5
StrRaknare = StrRaknare & (Siffra * 2)
Case 7
StrRaknare = StrRaknare & (Siffra * 2)
Case 9
StrRaknare = StrRaknare & (Siffra * 2)
Case Else
StrRaknare = StrRaknare & Siffra
End Select
Next b

For i = 1 To Len(StrRaknare)
Int1 = Int1 + Mid(StrRaknare, i, 1)
Next i

If Right(Int1, 1) <> 0 Then
Int2 = (Left(Int1, 1) + 1) * 10
Resultat1 = Int2 - Int1
If Right(NamnStr, 1) <> Resultat1 Then
MsgBox "Fraktsedelsnumret är inte rätt ifyllt, var god kontrolera inmatningen !", vbCritical, "Fraktsedelsnumret felaktigt"

End If
Else
Resultat2 = Int2 / 10
If Right(NamnStr, 1) = Resultat2 Then
MsgBox "Personnummret är inte rätt ifyllt, var god kontrolera inmatningen !", vbCritical, "Personnummer felaktigt"

End If
End If
End Sub


PÅ

Gör om subben till en Function som tar en inparameter och returnerar ett Boolskt värde. T.ex:

Public Function ValidatePnr(Pnr) As Boolean
    Dim sPnr As String
    Dim lIdx As Long
    Dim lNum As Long
    Dim lSum As Long
    
    On Error GoTo ValidatePnr_Err
    
        ' Tar bort ev bindestreck och de två första siffrorna vid ev fyrsiffrigt år
    sPnr = Replace(CStr(Pnr), "-", "")
    If Len(sPnr) = 12 Then sPnr = Mid$(sPnr, 3)
    
        ' Om strängen består av tio tecken går prog igenom dem ett och ett
    If Len(sPnr) = 10 Then
        For lIdx = 1 To 9 Step 2
            lNum = CLng(Mid$(sPnr, lIdx, 1)) * 2
            If lNum > 9 Then lNum = lNum \ 10 + lNum Mod 10
            lSum = lSum + lNum + CLng(Mid$(sPnr, lIdx + 1, 1))
        Next lIdx
        
        ValidatePnr = (lSum Mod 10 = 0)
    End If
    
    Exit Function
ValidatePnr_Err:
End Function

Hej
Min lösning

Option Explicit
Private Sub Command1_Click()
Dim tPnr As String
'Rätt 10 siffra är 3 Dvs 8604184153. Denna funktion kan du använda på alla data input
'postgiro siffror eller kontrollsiffror på Pg/bkg koder.
       tPnr = "860418-4157" 'Här ser du till att In personnummer ligger
       tPnr = Replace(tPnr, "-", "") ' om användren slagit 860418-4157
If Right$(tPnr, 1) = KontrollSiffra(Left$(tPnr, Len(tPnr) - 1)) Then
   MsgBox "Ok"
Else
   MsgBox "Fel Pnr"
End If
End Sub
'Min function klarar alla sifferkombinatione  4 - eller många
'testa gärna mot postgiro eller något annat.
'DVS jag tar fram rätt kontrollsiffra den längst till höger.
Private Function KontrollSiffra(ByVal nummer As String) As String
'Regel 1. alla beräkningar sker från slutet mot början.
'Därför blir det StrReverse
'Steg för steg så du kan följa tekniken
Dim tmpStr As String, sLen As Long, strKsum As String
Dim i As Long, Ksum As Long
      tmpStr = StrReverse(nummer) 'börja alltid bakifrån !
         sLen = Len(nummer)
'Siffror som skall multipliceras med 2
For i = 1 To sLen Step 2
 strKsum = strKsum & CStr(CLng(Mid$(tmpStr, i, 1)) * 2)
Next 'i
'Siffror som skall multipliceras med 1
For i = 2 To sLen Step 2
 strKsum = strKsum & Mid$(tmpStr, i, 1)
Next 'i
 sLen = Len(strKsum)
'Summera alla enskilda siffror tex 16 blir 1 + 6
For i = 1 To sLen
Ksum = Ksum + CLng(Mid$(strKsum, i, 1))
Next 'i
Ksum = 10 - (Ksum Mod 10)
If Ksum = 10 Then Ksum = 0
'Returnera resultatet
KontrollSiffra = CStr(Ksum)
End Function

TACK !!!! För ert engagemang, ni har löst problemet.

Även 22 december 2019 var den här posten användbar, nu finns den i mcparken.se