Espero que o código seja útil:

Function ABREVIARNOMES(Célula As Range, ParamArray NomesSemAbreviar()) As String
    Dim PrimeiroNome As String, Texto As String, _
    ÚltimoNome As String, Abrev As String
    Dim i As Integer, k As Integer, Opcional As Integer, Controle As Integer
    Dim Nome, Nomes, NomeSemAbreviar, PosiçãoInicial
    
    Application.Volatile
    
        
    'Se só houver uma palavra, somente ela é retornada
    Texto = Célula
    If InStr(1, Texto, " ") = 0 Then
        ABREVIARNOMES = Texto
        Exit Function
    End If
        
    'Retornar todas a palavras do nome para uma matriz
    Nomes = Split(Texto, " ")
            
    'Retornar o primeiro nome
    PrimeiroNome = Left(Texto, InStr(1, Texto, " ") - 1)
    
    'Retornar o último nome
    ÚltimoNome = Right(Texto, Len(Texto) - InStrRev(Texto, " ", -1))
        
    'Se não for informado o argumento opcional, é atribuída uma cadeia vazia
    If IsMissing(NomesSemAbreviar) Then
    Opcional = 1
    End If
        
    'Loop para percorrer os nomes do texto informado
    For Each Nome In Nomes
        Select Case Len(Nome)
        'Não abreviar conectores como "e"
        Case 1
        Abrev = Abrev & Nome & Space(1)
        'Não abreviar conectores como "de" ou "das"
        Case 2, 3
            If Left(Nome, 1) = "d" Then Abrev = Abrev & Nome & Space(1)
        Case Else
            'Execução para o caso em que não há argumentos opcionais
            If Opcional = 1 Then
                Abrev = Abrev & UCase(Left(Nome, 1)) & "." & Space(1)
            Else
                'Quando há argumentos opcionais testa o nome contra cada um deles
                For Each NomeSemAbreviar In NomesSemAbreviar
                    If Nome = NomeSemAbreviar Then
                    Controle = 1
                    Exit For
                    Else
                    Controle = 0
                    End If
                Next NomeSemAbreviar
                
                If Controle = 1 Then
                'Se for encontrada coincidência com os argumentos opcionais, não realiza abreviatura
                Abrev = Abrev & Nome & Space(1)
                Else
                'Se não for encontrada coincidência com os argumentos opcionais, realiza abreviatura
                Abrev = Abrev & UCase(Left(Nome, 1)) & "." & Space(1)
                End If
            End If
        End Select
    Next Nome
    
    'Criar o nome final definitivo, com abreviaturas e demais considerações
    Abrev = PrimeiroNome & Right(Abrev, Len(Abrev) - InStr(1, Abrev, "."))
    ABREVIARNOMES = Left(Abrev, Len(Abrev) - 3) & ÚltimoNome

End Function

Eis o arquivo com as aplicações: http://www.4shared.com/document/3N7IwZQW/Abreviao_de_Nomes.html