A funcção abaixo faz quase isto. mas vc pode alterar seu código para sua necessidade.

 

 

 

Public Function NomeCracha(sNome As String, nMax As Integer) As String
    '
    Dim Primeiro As String, Ultimo As String    ' Primeiro e Último Nome.
    Dim PIni As Integer, PFim As Integer        ' Posições de Início e Fim da string.
    Dim Old As String, i As Integer             ' Armazenar caracter.
    Dim Achou As Boolean
    On Error GoTo err_NomeCracha
   
    If Len(Trim((sNome))) = 0 Then Exit Function
   
    i = Len(Trim(sNome))
    '
    Primeiro = Left(sNome, InStr(sNome, " "))
    Ultimo = Right(sNome, (i - InStrRev(sNome, " ")))
    '
    If sNome = (Primeiro & Ultimo) Or i <= nMax Then
        i = Len(Trim(Primeiro & Ultimo))
        If i > nMax Then
            NomeCracha = Trim(Primeiro)
        Else
            NomeCracha = Trim(sNome)
        End If
        Exit Function
    End If
    '
    Select Case UCase(Trim(Ultimo))
        Case "JUNIOR", "JÚNIOR": Achou = True: Ultimo = "JR."
        Case "FILHO": Achou = True: Ultimo = "Fº."
        Case "FILHA": Achou = True: Ultimo = "Fª."
        Case "NETO", "NETA": Achou = True
        Case "Fº", "Fº.": Achou = True: Ultimo = "Fº."
        Case "Fª", "Fª.": Achou = True: Ultimo = "Fª."
        Case "F", "F.": Achou = True: Ultimo = "F."
        Case "JR", "JR.": Achou = True: Ultimo = "JR."
        Case Else: Achou = False
    End Select
    '
    If Achou Then
        PFim = i - Len(Right(sNome, (i - InStrRev(sNome, " "))))
        PFim = InStrRev(Left(sNome, (PFim - 1)), " ")
    Else
        PFim = i - Len(Ultimo)
    End If
    '
    PIni = InStrRev(Left(sNome, (PFim - 1)), " ")
    Old = Mid(sNome, (PIni + 1), (PFim - (PIni + 1)))
    Select Case UCase(Trim(Old))
        Case "DA", "DE", "DI", "DO", "DOS", "DAS": Achou = True
        Case Else: Achou = False
    End Select
    '
    If Achou And PIni > 0 Then
        NomeCracha = Trim(Primeiro) & Mid(Trim(sNome), PIni, (InStrRev(sNome, " ") - PIni)) & " " & Ultimo
    Else
        NomeCracha = Trim(Primeiro) & Mid(Trim(sNome), PFim, (InStrRev(sNome, " ") - PFim)) & " " & Ultimo
    End If
    '
    ' Verif. se o Texto cabe no campo.
    i = Len(Trim(NomeCracha))
    If i > nMax Then
        NomeCracha = Trim(Primeiro) & " " & Ultimo
        '
        i = Len(Trim(NomeCracha))
        If i > nMax Then NomeCracha = Trim(Primeiro)
    End If
   
    Exit Function
    '
err_NomeCracha:
    NomeCracha = Trim(sNome)
    On Error GoTo 0

End Function