Hejsan

Jag har en modul som kontrollerar personnummer. Om man hittar ett felaktigt personnummer ska hela macrot avslutas och inte bara modulen. Någon som har någon lösning på detta?

Jesse

Med macro, menar du ett macro i Word eller Excel?

I exemplet nedanför avslutas makrot/subrutinen "MittMakro" om funktionen "KollaPersonnummer" returnerar "False".

<code>

Public Sub MittMakro()
Dim sPersonnummer As String

sPersonnummer = Selection
If KollaPersonnummer(sPersonnummer) = True Then
' Kod som körs om personnumret var giltigt
MsgBox sPersonnummer & " är ett giltigt personnummer."
End If
End Sub

Private Function KollaPersonnummer(ByVal vsPnr As String) As Boolean
' kod för att kontrollera personnumret
' KollaPersonnumret sätts till "True" om personnumret var korrekt
End Function

</code>

Hej

Det är rätt att det är ett macro i Excel.

Personnummermodulen ser ut som följer:

<Code>
Public Sub pnrKontroll(pStr As String)

Dim StrRaknare As String
Dim NamnStr As String
Dim Int1 As Integer
Dim Resultat2 As Integer
Dim Resultat1 As Integer
Dim b As Integer
Dim i As Integer
Dim Int2 As Integer
Dim Siffra As Integer
Dim pRow As Long
Dim pCol As Long
Dim fName As String

endIndex = Cells(Rows.Count, "A").End(xlUp).Row 'Cells(4, "A").End(xlDown).Row
tTecken = "-"
With ActiveSheet.UsedRange
For pRow = 3 To endIndex
pCol = 3
pStr = pStr & CStr(.Cells(pRow, pCol))

If InStr(pStr, "-") Then
MsgBox ("Kontrollera att du inte har ett bindestreck på rad " & pRow)
Exit Sub

Else
End If

StrRaknare = ""
Int1 = 0
Int2 = 0
Siffra = 0
NamnStr = Left(pStr, 6) & Right(pStr, 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 "Personnummret på rad " & pRow & " är inte rätt ifyllt, var god kontrollera
inmatningen !", vbInformation, "Personnummer felaktigt"
Exit Sub

End If
Else
Resultat2 = Int2 / 10
If Right(NamnStr, 1) = Resultat2 Then
MsgBox "Personnummret på rad " & pRow & " är inte rätt ifyllt, var god kontrollera
inmatningen !", vbInformation, "Personnummer felaktigt"
Exit Sub

End If
End If
pStr = ""
Next pRow
End With

End Sub
</Code>

Denna modul exekveras med en Call pnrKontroll i huvudmacrot sparaCmd_Click()

<Code>
Public Sub sparaCmd_Click()

Dim sFilename As String
Dim sRow As String
Dim nCol As Long
Dim nRow As Long
Dim nFile As Integer
Dim nFile1 As Integer
Dim nFile2 As Integer
Dim tmpArray() As String
Dim strIn As String
Dim sTmp As String
Dim pStr As String
Dim fName As String
Const DELIM As String = ";"
Dim Lastrow As Integer

Call RemoveEmptyRows
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Call pnrKontroll(pStr)

fName = InputBox("Var vänlig ange namn på filen som ska skickas")
sFilename = fName & ".txt"
nFile = FreeFile
Open ActiveWorkbook.Path & "\" & sFilename For Output As #nFile

With ActiveSheet.UsedRange
For nRow = 3 To Lastrow
sRow = ""
For nCol = 1 To .Columns.Count
If sRow <> "" Then sRow = sRow & DELIM
sRow = sRow & CStr(.Cells(nRow, nCol))
Next nCol
Print #nFile, sRow
Next nRow
End With
Close #nFile

nFile1 = FreeFile
Open ActiveWorkbook.Path & "\" & sFilename For Input As #nFile1
nFile2 = FreeFile
Open ActiveWorkbook.Path & "\" & "tempFil.txt" For Output As #nFile2
Do Until EOF(nFile1)
Line Input #nFile1, strIn
tmpArray = Split(strIn, ";")
sTmp = ("H1;IN" & ";H2;" & tmpArray(0) & ";H3;" & tmpArray(1) & ";H4;19" & tmpArray(2) & ";H5;"
& tmpArray(3) & ";H6;" & tmpArray(4) & ";H7;" & tmpArray(5) & ";CR")
Print #nFile2, sTmp
Loop

Close #nFile1
Close #nFile2
Kill ActiveWorkbook.Path & "\" & sFilename
Name ActiveWorkbook.Path & "\" & "tempFil.txt" As ActiveWorkbook.Path & "\" & fName & ".txt"
NumRows = 0

End Sub
</Code>

Som ni ser får man frågan om att ange filnamn även om ett personnummer är felaktigt, det är det jag vill få bort. Då tänkte jag att om man får en träff på ett felaktigt personnummer ska fortsättningen på macrot avbrytas, går det att ordna på något enkelt sätt. Jag förstod inte riktigt hur jag ska kunna implementera excemplet Åsa gav utan att behöva skriva om stora delat av macrot, det kanske går men jag vet som sagt inte hur.

Hoppas denna förklaring hjälper.

Mitt exempel i din tappning skulle se ut så här:

<code>
Private Function pnrKontroll() As Boolean
Dim StrRaknare As String
Dim NamnStr As String
Dim Int1 As Integer
Dim Resultat2 As Integer
Dim Resultat1 As Integer
Dim b As Integer
Dim i As Integer
Dim Int2 As Integer
Dim Siffra As Integer
Dim pRow As Long
Dim pCol As Long
Dim fName As String
Dim endIndex As Long
Dim tTecken As String
Dim pStr As String

endIndex = Cells(Rows.Count, "A").End(xlUp).Row 'Cells(4, "A").End(xlDown).Row
tTecken = "-"
With ActiveSheet.UsedRange
For pRow = 3 To endIndex
pCol = 3
pStr = pStr & CStr(.Cells(pRow, pCol))

If InStr(pStr, "-") Then
MsgBox ("Kontrollera att du inte har ett bindestreck på rad " & pRow)
Exit Function
End If

StrRaknare = ""
Int1 = 0
Int2 = 0
Siffra = 0
NamnStr = Left(pStr, 6) & Right(pStr, 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 "Personnummret på rad " & pRow & " är inte rätt ifyllt, " _
& "var god kontrollera inmatningen !", _
vbInformation, "Personnummer felaktigt"
Exit Function
End If
Else
Resultat2 = Int2 / 10
If Right(NamnStr, 1) = Resultat2 Then
MsgBox "Personnummret på rad " & pRow & " är inte rätt ifyllt, " _
& "var god kontrollera inmatningen !", _
vbInformation, "Personnummer felaktigt"
Exit Function
End If
End If
pStr = ""
Next pRow
End With

pnrKontroll = True
End Function
</code>

<code>
Public Sub sparaCmd_Click()
Dim sFilename As String
Dim sRow As String
Dim nCol As Long
Dim nRow As Long
Dim nFile As Integer
Dim nFile1 As Integer
Dim nFile2 As Integer
Dim tmpArray() As String
Dim strIn As String
Dim sTmp As String
Dim pStr As String
Dim fName As String
Const DELIM As String = ";"
Dim Lastrow As Integer
Dim NumRows As Long

Call RemoveEmptyRows
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row

If pnrKontroll() = True Then
fName = InputBox("Var vänlig ange namn på filen som ska skickas")
sFilename = fName & ".txt"
nFile = FreeFile
Open ActiveWorkbook.Path & "\" & sFilename For Output As #nFile

With ActiveSheet.UsedRange
For nRow = 3 To Lastrow
sRow = ""
For nCol = 1 To .Columns.Count
If sRow <> "" Then sRow = sRow & DELIM
sRow = sRow & CStr(.Cells(nRow, nCol))
Next nCol
Print #nFile, sRow
Next nRow
End With
Close #nFile

nFile1 = FreeFile
Open ActiveWorkbook.Path & "\" & sFilename For Input As #nFile1
nFile2 = FreeFile
Open ActiveWorkbook.Path & "\" & "tempFil.txt" For Output As #nFile2
Do Until EOF(nFile1)
Line Input #nFile1, strIn
tmpArray = Split(strIn, ";")
sTmp = ("H1;IN" & ";H2;" & tmpArray(0) & ";H3;" & tmpArray(1) _
& ";H4;19" & tmpArray(2) & ";H5;" & tmpArray(3) & ";H6;" _
& tmpArray(4) & ";H7;" & tmpArray(5) & ";CR")
Print #nFile2, sTmp
Loop

Close #nFile1
Close #nFile2
Kill ActiveWorkbook.Path & "\" & sFilename
Name ActiveWorkbook.Path & "\" & "tempFil.txt" As ActiveWorkbook.Path _
& "\" & fName & ".txt"
NumRows = 0
End If
End Sub
</code>

Ett litet PS om hur du kan förkorta din CASE-sats betydligt:

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

Det fungerade perfekt. Tack så mycket för hjälpen.

Jesse