Need help with optimizing VBA parsing string for middle initial from several variants!

Please note the following code:

Here are the test cases that work:
DEL VALLE, ADRIAN
Danielle L. Temple
ALMAGUER III, JUAN M
GREEN PINKEY, STACEY Y

Here are the test cases that do not work:
Smittick, Donesha M.
PIERCE, JR., ROBERT J
JORDAN, Savannah L.


How may I change the below syntax to work properly or make it more succinct?

Public Function PullMiddleInitial(vFullName As Variant) As String
On Error GoTo Err_Proc

  Dim sFullName As String
  Dim sFirst As String
  Dim sMiddle As String
  Dim i As Integer
  Dim lCountSpace As Long

  If Not IsNull(vFullName) Then
    sFullName = vFullName
    DoEvents
    
    If CommaBeforeSpace(sFullName) = True Then
      'find where , comma is
      sFullName = Trim(Right(sFullName, Len([sFullName]) - InStr([sFullName], ",")))
      'it's a first name only with a space and middle initial is:
      If Len(sFullName) > 1 And CountofCharacterInString(sFullName, " ") = 1 Then
        sMiddle = Right(sFullName, 2)
        If Left(sMiddle, 1) = " " Then
          sMiddle = Trim(sMiddle)
        Else
          sMiddle = ""
        End If
      End If
    Else
      
      sMiddle = ""
      If CountofCharacterInString(sFullName, " ") > 1 Then
        '
        lCountSpace = 0
        If OneSpaceThenPeriod(sFullName) = True Then
          For i = 1 To Len(sFullName)
            If Mid(sFullName, i, 1) = " " Then
              If Not i + 1 > Len(sFullName) Then
                sMiddle = Mid(sFullName, i + 1, 1)
                Exit For
              End If
            End If
            
          Next
          
        Else
          For i = 1 To Len(sFullName)
            If Mid(sFullName, i, 1) = " " Then
              
              lCountSpace = lCountSpace + 1
            End If
            If Mid(sFullName, i, 1) = " " And lCountSpace = 2 Then
              'find 2nd space after
              If Not i - 1 < 1 And Len(sFullName) > 2 Then
                
                sMiddle = Mid(sFullName, i - 2, 3)
                If Left(sMiddle, 1) = " " Then
                  If Right(sMiddle, 1) = " " Then
                    sMiddle = Mid(sMiddle, 2, 1)
                    Exit For
                  End If
                Else
                  sMiddle = ""
                  Exit For
                End If
                
              End If
            End If
            
            If lCountSpace > 2 Then
              Exit For
            End If
            
            If Mid(sFullName, i, 1) = "." Then
              If i <> Len(sFullName) And Mid(sFullName, i - 2, 1) = " " Then
                If Not i - 1 < 1 Then
                  
                  sMiddle = Mid(sFullName, i - 1, 1)
                  sMiddle = Trim(sMiddle)
                  Exit For
                End If
              Else
                sMiddle = ""
                Exit For
              End If
            End If
          Next
          
        End If
      
      End If
    End If
  Else
    If CountofCharacterInString(sFullName, " ") = 1 Then
      
      sMiddle = Right(sFullName, 2)
      If Left(sMiddle, 1) = " " Then
        sMiddle = Right(sFullName, 1)
      Else
        sMiddle = ""
        
      End If
      
    End If
  End If

Exit_Proc:

  If CharacterOnly(sMiddle) = False Then
    sMiddle = ""
  End If

  If sMiddle <> "" Then PullMiddleInitial = sMiddle
  Exit Function
  
Err_Proc:
  Call LogError(Err, Err.Description, "_mTasks @ PullMiddleInitial")
  Resume Exit_Proc
End Function

Public Function CountofCharacterInString(sValue As String, sCharacter As String) As Long
On Error GoTo Err_Proc

  Dim lCount As Long
  lCount = Len(sValue) - Len(Replace(sValue, sCharacter, ""))
  
Exit_Proc:
  CountofCharacterInString = lCount
  Exit Function
  
Err_Proc:
  Call LogError(Err, Err.Description, "_mTasks @ CountofCharacterInString")
  Resume Exit_Proc

End Function

Select allOpen in new window