Do
k = k + 1 
max = 0 'введем переменную для учета максимального количества закрытия единицами нулей
For i = 1 To UBound(massiv1, 1)
    Perekritie = 0
        For j = 1 To UBound(massiv1, 1)
                If PoleSovpaden(1, j) = 0And PoleSovpaden(i, j) = 1 Then Perekritie = Perekritie + 1
        Next j
        PerekritieM(i) = Perekritie 'запоминаем сумму перекрытий i-ой строки
        If PerekritieM(i) > max Then
           max = PerekritieM(i)
           n = i ' переменная для номера строки имеющего максимальное совпадение с первой строкой.
        If max = Pred_Max Then Exit For 'если достигнуто предыдущее число совпадений то нет смысла дальше вести цикл
        Else
        End If
Next i
 Pred_Max = max 'запоминание предыдущего максимального числа совпадений
 If max = 0 Then Exit Do ' - сформировалась строка из единиц, либо больше нечем заменять..
 ReDim Preserve NStroki(k)
 NStroki(k) = n

MsgBox "колво совпадений: " & max & "  Номер строки: " & n & "  Строка по счету - " & k
zamena = 0 'количество замен будет равно количеству максимальных перекрытий.....,
For i = 1 To UBound(massiv1, 1)
    If PoleSovpaden(1, i) = 0 And PoleSovpaden(n, i) = 1 Then
    PoleSovpaden(1, i) = 1 ' меняем НУЛИ на ЕДИНИЦЫ в ИСХОДНИКЕ, меняем ИСХОДНИК до тех пор пока он не будет весь из ЕДИНИЦ
    zamena = zamena + 1  ' достигнуто  (число max), то нет смысла дальше продолжать цикл
    End If
    If zamena = max Then Exit For
Next i
Loop

Private Function last_row_column(iRow, iClm) As Integer
      If Cells(1, 1) = "" Or Cells(1, 1) = 0 Then
      iRow = 0 And iClm = 0
      Exit Function
      Else
      iRow = Columns.End(xlDown).Row
      iClm = Rows.End(xlToRight).Column
    End If
End Function

Private Sub CommandButton1_Click()
Dim M1(), p&, i&, j&, y&, Sovpadenie&
Dim MSovpaden() As Boolean
Dim tv As Single
cat = 10 ' задаем число совпадений, может быть любое
M1 = [A1].CurrentRegion.Value
ReDim MSovpaden(UBound(M1), UBound(M1)) As Boolean
tv = Timer
MaxN = UBound(M1) - cat
For i = 1 To UBound(M1)
    For p = i + 1 To UBound(M1)
    Sovpadenie = 0
    n = 0
            For j = 1 To UBound(M1, 2)
                If M1(i, j) = M1(p, j) Then Sovpadenie = Sovpadenie + 1 Else n = n + 1
            Next j
    If n > MaxN Then Exit For
    If Sovpadenie >= cat Then MSovpaden(i, p) = True ' условие формирования массива совпадений
    Next p
Next i
'Worksheets(2).[A1].Resize(UBound(MSovpaden), UBound(MSovpaden)).Value = Application.Transpose(MSovpaden)
MsgBox Timer - tv
End Sub

Dim sh As Worksheet
Dim mas1() As Variant 
Dim mas2() As Variant 
For Each sh In ThisWorkbook.Worksheets
 j=1   
      For i = 1 To 130 '130 навскидку потому что не знаю до конца сколько у меня рабочих на листе.
        p = sh.Cells(i + 13, 6) - фамилии начинаются с 14 строки, и присутствую НЕ В КАЖДОЙ строке.
   If p = 0 Or p = "" Or  Then  GoTo 10 'ускорить таким образом хотел, чтоб сразу на след клетку если пусто
      Else

       mas2(j, 1) = sh.Cells(i + 13, 6)'формируется массив с фамилией... 
            mas2(j, 2) = sh.Cells(i + 13, 9)' ..и суммой
End If
o = o + 1
10    Next i