'Kuzmich 23 апреля 2014 года
'http://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=56661

Private Sub CommandButton2_Click()
Dim i As Integer
Dim n As Integer
Dim iLastRow As Integer
Dim BeginRow As Integer
Dim iFIO As String
Dim FoundFIO As Range
Dim FirstFIO As String

    With Application
      .ScreenUpdating = False             'отключение обновление экрана
      .Calculation = xlCalculationManual  'отключение пересчёт формул вручную
      .DisplayAlerts = False              'отключение предупреждающих сообщений
    End With
        
        iLastRow = Cells(Rows.Count, 27).End(xlUp).Row
    For i = 1 To iLastRow                 'цикл по ФИО в столбце АА
        iFIO = Cells(i, 27)               'очередная ФИО
            'ищем ФИО в столбце Р реестра
            Set FoundFIO = Columns("P").Find(iFIO, , xlValues, xlWhole)
        If Not FoundFIO Is Nothing Then
            FirstFIO = FoundFIO.Address   'адрес первой найденной ФИО
                'копируем лист(.) в конец книги
                Worksheets(".").Copy After:=Worksheets(Worksheets.Count)
                    ActiveSheet.Name = iFIO 'присваиваем листу имя ФИО
                BeginRow = 28               'начальная строка вставки данных
                n = 1
                Worksheets("реестр менее свернутый").Activate
            With Worksheets(iFIO)
                .Range("G79") = iFIO                         'ФИО
                .Range("D79") = Cells(i, 28)                 'должность
            Do
                .Cells(BeginRow, 1) = n                      'порядковый номер
                .Cells(BeginRow, 2) = Cells(FoundFIO.Row, 6) 'наименование
                .Cells(BeginRow, 4) = Cells(FoundFIO.Row, 2) 'дата выпуска
                .Cells(BeginRow, 5) = Cells(FoundFIO.Row, 3) 'дата приобретения
                .Cells(BeginRow, 6) = Cells(FoundFIO.Row, 4) 'срок службы
                '
                'остальные колонки аналогично
                '
                    .Rows(BeginRow + 1).Insert xlDown        'добавляем строку
                    .Range(.Cells(BeginRow, 2), .Cells(BeginRow, 3)).MergeCells = True
                    .Range(.Cells(BeginRow, 1), .Cells(BeginRow, 11)).Borders.Weight = xlThin
                BeginRow = BeginRow + 1
                n = n + 1
                'ищем следующее вхождение ФИО
              Set FoundFIO = Columns("P").FindNext(FoundFIO)
            Loop While FoundFIO.Address <> FirstFIO
            End With
        Else
            MsgBox iFIO & " Нет такой фамилии в столбце P"
        End If
    Next
    
    With Application
      .ScreenUpdating = True
      .Calculation = xlCalculationAutomatic
      .DisplayAlerts = True
    End With
End Sub