Private Sub Command1_Click()
Dim llngFirstSpace As Long 'Sorry for all Dims but just added to hopefully make more sense
Dim lstrText As String
Dim lstrInitials As String
Dim lstrSecondName As String
Dim lintCounter As Integer
Dim lstrResult As String
lstrText = Text1.Text 'Read into array for easier handling
llngFirstSpace = InStr(1, lstrText, " ") - 1 'Find occurrence of first space / indicates initials
lstrInitials = Left$(lstrText, llngFirstSpace) 'Parse off initials
lstrSecondName = Right$(lstrText, Len(lstrText) - llngFirstSpace) 'Parse off remainder
lstrInitials = Replace(lstrInitials, ".", "") 'Remove all dots before starting - saves checking
For lintCounter = 1 To Len(lstrInitials) 'Loop thru initials
lstrResult = lstrResult & Mid$(lstrInitials, lintCounter, 1)
If lintCounter < Len(lstrInitials) Then lstrResult = lstrResult & "."
'lstrResult = lstrResult & Mid$(lstrInitials, lintCounter, 1) & "."
'Commented out line adds dots after all letters instead of all but last
Next
Text2.Text = lstrResult & lstrSecondName 'Reform the name
End Sub