VBA kode til tildeling af ledige initialer

Kunne du forestille dig en dialogboks, hvori de nye initialer indtastes - kontrolleres og evt. tilføjes hvis OK?

Det er lige præcis det, jeg er ude efter.

OK, vender tilbage :-)

Koden i userformen er følgende - men hvis du vil have hele excel-file incl. alt - så send en mail til pb@skivehs.dk.
I userformen er der en tekstbox (initialer) m/max lgd på 4 tegn. En label (meddelelse) samt to knapper - OK & Luk.
I ThisWorkbook loades formularen.
- - - -



Dim sidsteRække As Integer
Private Sub LUK_Click()
    Unload nyeInitialer
End Sub
Private Sub OK_Click()
Dim bemærkninger As String
    Meddelelse.Caption = ""
    If findes(UCase(initialer)) = True Then
        Meddelelse.Caption = "Findes i forvejen"
    Else
        If Len(initialer) >= 2 Then
            bemærkninger = okInitialer(UCase(initialer))
            If bemærkninger = "" Then
                sidsteRække = sidsteRække + 1
                ActiveSheet.Cells(sidsteRække, 1).Value = initialer
                Meddelelse.Caption = "Ok - tilføjes"
            Else
                Meddelelse.Caption = bemærkninger
            End If
        Else
            Meddelelse.Caption = "For få tegn i initialer"
        End If
    End If
   
    initialer.SetFocus
End Sub
Private Function findes(init)
Dim f
    For f = 1 To sidsteRække
        If UCase(Cells(f, 1)) = init Then
            findes = True
            Exit Function
        End If
    Next f
    findes = False
End Function
Private Function okInitialer(init)
Dim førsteTegn, illegaleTegn1 As String, illegaleTegnx As String, fejl As String, f
    illegaleTegn1 = "QZ"
    illegaleTegnx = "ÆØÅ"
    fejl = ""
   
    førsteTegn = Left(init, 1)
    If InStr(illegaleTegn1, førsteTegn) = 1 Then
        fejl = "Må ikke begynde med Q eller Z!" + vbCr
    End If
   
    For f = 1 To Len(init)
        If InStr(illegaleTegnx, Mid(init, f, 1)) > 0 Then
            fejl = fejl + "Må ikke indeholde Æ, Ø eller Å"
            okInitialer = fejl
            Exit Function
        End If
    Next f
   
    okInitialer = fejl
End Function
Private Sub UserForm_activate()
    sidsteRække = ActiveCell.SpecialCells(xlLastCell).Row    'henter sidste celle
End Sub

Den funker :) så smid et svar.

Det var godt - så er svaret her!