' Стереть код и написать вот так ? 

 Public Function isv(stroka As String) As String
fam = ""
j =  1 
    Do
        c = Mid(stroka, j,  1 )
            If c <> " " Then
                fam = fam + c
            Else
                fam = fam + c
                c = Mid(stroka, j +  1 ,  1 )
                fam = fam + c
                c = Mid(stroka, j +  2 ,  1 )
                fam = fam + c
                Exit Do
            End If
            j = j +  1 
        Loop While j <= Len(stroka)
        isv = fam
End Function

Private Sub CommandButton1_Click()
Dim a As String
Dim d As String
Dim z As String

CommandButton1.Caption = "Подождите"
N =  0 
Do While Cells(N +  2 ,  5 ).Value <> ""
     N = N +  1 
Loop

For i =  2  To N +  1 
 j =  5 
Do While Cells(i, j).Value <> ""
    Cells(i, j).Value = ""
    j = j +  1 
Loop
Next
 
For i =  3  To ActiveWorkbook.Worksheets.Count
 
    NI =  0 
    Do While Worksheets(i).Cells(NI +  10 ,  3 ).Value <> ""
        NI = NI +  1 
    Loop
 
For j =  10  To  10  + NI -  1 
    z = isv(Worksheets(i).Cells(j,  3 ).Value)
    N =  0 
    Do While Cells(N +  2 ,  5 ).Value <> ""
        N = N +  1 
    Loop
    flag =  0 
    For ii =  2  To N +  1 
        d = Cells(ii,  5 ).Value
        If StrComp(d, z) =  0  Then
            flag =  1 
            Exit For
        End If
    Next
    If flag =  0  Then
        Cells(N +  2 ,  5 ).Value = z
    End If
Next
Next

Nfam =  0 
Do While Cells(Nfam +  2 ,  5 ).Value <> ""
    Nfam = Nfam +  1 
Loop
For i =  2  To Nfam +  1 
    d = Cells(i,  5 ).Value
    nom =  7 
    sym =  0 

        For ii =  33  To ActiveWorkbook.Worksheets.Count
           N =  0 
        Do While Worksheets(ii).Cells(N +  10 ,  3 ).Value <> ""
            N = N +  1 
        Loop
 
    For j =  10  To  10  + N -  1 
        a = Worksheets(ii).Cells(j,  3 ).Value
        z = isv(a)
        If StrComp(d, z) =  0  Then
            If IsNumeric(Worksheets(ii).Cells(j,  7 ).Value) = True Then
            Cells(i, nom).Value = Worksheets(ii).Cells(j,  7 ).Value
            Cells(i, nom +  1 ).Value = Worksheets(ii).Cells(j,  1 ).Value
            nom = nom +  2 
            sym = sym + CLng(Worksheets(ii).Cells(j,  7 ).Value)
            End If
        End If
    Next
Next
     
Cells(i,  6 ).Value = sym
Next
    
N =  0 
Do While Cells(N +  2 ,  5 ).Value <> ""
    N = N +  1 
Loop
CommandButton1.Caption = "Вычислить"
End Sub

Public Function isv(stroka As String) As String
fam = "" ' Переменная для выделения фамилии с инициалми
j =  1  'Счетчик симвалов в исходной строке
    Do
        c = Mid(stroka, j,  1 )  '  Извлечение очередного символа
            If c <> " " Then
                fam = fam + c
            Else
                ' После появления пробела считываем еще инициалы
                fam = fam + c
                c = Mid(stroka, j +  1 ,  1 )
                fam = fam + c
                c = Mid(stroka, j +  2 ,  1 )
                fam = fam + c
                Exit Do
            End If
            j = j +  1 
        Loop While j <= Len(stroka)
        'MsgBox j & " | " & stroka
        isv = fam
End Function

Private Sub ComboBox1_Change()
N =  0 
Do While Cells(N +  2 ,  5 ).Value <> ""
    N = N +  1 
    Loop
'Цикл по количеству  фамилий студентов.
    For i =  2  To N +  1 
' При нахождении на листе фамилии, соответсвующей выбранному  элементу списка.
        If StrComp(ComboBox1.Text, Cells(i,  5 ).Value) =  0  Then
        ' подтягивание нужной строки на экран.
        Cells(i,  5 ).Select
        End If
    Next
End Sub

Private Sub CommandButton1_Click()
Dim a As String
Dim d As String
Dim z As String

CommandButton1.Caption = "Подождите"

' Подсчет колличества строк с фамилиями на первом лите
N =  0 
Do While Cells(N +  2 ,  5 ).Value <> ""
     N = N +  1 
Loop
' Очистка заполненных ячеек оплат на первом листе.
For i =  2  To N +  1 
 j =  5 
Do While Cells(i, j).Value <> ""
    Cells(i, j).Value = ""
    j = j +  1 
Loop
Next

' Цикл по листам данных
For i =  3  To ActiveWorkbook.Worksheets.Count
' Подсчет количесва строк с фамилиями на i-м листе
    NI =  0 
    Do While Worksheets(i).Cells(NI +  10 ,  3 ).Value <> ""
        NI = NI +  1 
    Loop

' Цикл по количеству строк на i-м листе
For j =  10  To  10  + NI -  1 
    ' Функция, извлекающая из ячейки только фамилию инициалами
    z = isv(Worksheets(i).Cells(j,  3 ).Value)
    ' фрагмент для добавления фамилии на первый лист
    N =  0 
    Do While Cells(N +  2 ,  5 ).Value <> ""
        N = N +  1 
    Loop
    flag =  0  ' индикатор присудствия очередной фамилии c  листа данных на первом листе
    For ii =  2  To N +  1 
        d = Cells(ii,  5 ).Value
        If StrComp(d, z) =  0  Then
            flag =  1 
            Exit For
        End If
    Next
    If flag =  0  Then 'если фамилия не найдена
        Cells(N +  2 ,  5 ).Value = z
    End If
Next
Next

' В следующем блоге производится подсчет оплат

Nfam =  0 
Do While Cells(Nfam +  2 ,  5 ).Value <> ""
    Nfam = Nfam +  1 
Loop

'Цикл по фамилиям студентов
For i =  2  To Nfam +  1 
 ' в переменной d очередная фамилия
    d = Cells(i,  5 ).Value
    nom =  7  ' в этой переменной организуем счетчик по столбцам
    sym =  0  ' переменная для подсчета суммы всех оплат студента
    
        ' цикл по количеству листов данных
        For ii =  33  To ActiveWorkbook.Worksheets.Count
        
         ' подсчет кол-ва фомилий на очередном листе данных
        N =  0 
        Do While Worksheets(ii).Cells(N +  10 ,  3 ).Value <> ""
            N = N +  1 
        Loop
        
    ' цикл по фамилиям на очередном листе с данными
    For j =  10  To  10  + N -  1 
        a = Worksheets(ii).Cells(j,  3 ).Value
        z = isv(a)
        If StrComp(d, z) =  0  Then ' Если фамилия найдена
            If IsNumeric(Worksheets(ii).Cells(j,  7 ).Value) = True Then
        ' установка суммы очередной оплыты.
            Cells(i, nom).Value = Worksheets(ii).Cells(j,  7 ).Value
        ' установка даты очередной оплыты.
            Cells(i, nom +  1 ).Value = Worksheets(ii).Cells(j,  1 ).Value
        ' Переход к следующей паре столбцов
            nom = nom +  2 
        ' Суммирование оплаты конкретного  сутдента
            sym = sym + CLng(Worksheets(ii).Cells(j,  7 ).Value)
            End If
        End If
    Next
Next
     
' Запись итоговой суммы в шестой стобец
Cells(i,  6 ).Value = sym
Next
    
' Подсчет в переменной N фамилий студентов
N =  0 
Do While Cells(N +  2 ,  5 ).Value <> ""
    N = N +  1 
Loop

'  Заполнение поля со списком фамилиями  с первого листа
ComboBox1.Clear
For i =  2  To N +  1 
     d = Worksheets( 1 ).Cells(i,  5 ).Value
     ComboBox1.AddItem d
Next

' Завершение обоработки и смена надписи на кнопке
   CommandButton1.Caption = "Вычислить"
End Sub

Private Sub CommandButton2_Click()
Dim a As String
Dim z As String

If ActiveCell.Column <>  5  Or ActiveCell.Row =  1  Or ActiveCell.Value = "" Then
  Exit Sub
End If

' Вывод в надпись фамилии студента из выделенной (активной) ячейки
Lbl.Caption = ActiveCell.Value
' в переменной s фиксируется номер строки выдленной ячейки.
s = ActiveCell.Row
'Впеременной nom организуется счетчик стобцов
nom =  7 
' в переменной sym организуется суммы по всем оплатам
sym =  0 
' Очистка высплывающего текстового окна.
TextBox1.Text = ""

' Цикл по литам данных.
For i =  3  To ActiveWorkbook.Worksheets.Count
    N =  0 
    Do While Worksheets(i).Cells(N +  10 ,  3 ).Value <> ""
        N = N +  1 
    Loop
' Цикл по строкам на листах данных
For j =  10  To  10  + N -  1 
    a = Worksheets(i).Cells(j,  3 ).Value
    z = isv(a)
' Если интересующая фамилия найдена на листах данных
    If StrComp(Lbl.Caption, z) =  0  Then
        'Если в поле для суммы оплаты - число
        If IsNumeric(Worksheets(i).Cells(j,  7 ).Value) = True Then
        'запись информации на первый лист
         Cells(s, nom).Value = Worksheets(i).Cells(j,  7 ).Value
         Cells(s, nom +  1 ).Value = Worksheets(i).Cells(j,  1 ).Value
        'Увеличение Счетчика столбцов
         nom = nom +  2 
        'Подсчет суммы
         sym = sym + CLng(Worksheets(i).Cells(j,  7 ).Value)
        'вывод информации во всплывающее текстовое окно
            TextBox1.Text = TextBox1.Text + _
                CStr(Worksheets(i).Cells(j,  7 ).Value) + "    "
            TextBox1.Text = TextBox1.Text + _
                CStr(Worksheets(i).Cells(j,  1 ).Value) + Chr( 10 )
        End If
    End If
Next
Next
' Вывод итоговой информации
    Worksheets( 1 ).Cells(s,  6 ).Value = sym
'Установка видимости текстового окна
    TextBox1.Visible = True
End Sub


Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
TextBox1.Visible = False
End Sub 

Next
' Запись итоговой суммы в шестой стобец
Cells(i,  6 ).Value = sym
Next