Поиск последнего столбца и копирование - VBA

Формулировка задачи:

Всем добрый день. Ребята подскажите пожалуйста, как найти столбец с именем "Столбец 25", в столбце найти строки с значением "Номер один" и все это , вместе со строками и шапкой скопировать на новый лист.

Решение задачи: «Поиск последнего столбца и копирование»

textual
                            Листинг программы 
                        

                            Option Explicit
 
Private Sub disAccelerateExcel() 'Включаем всё то что выключили процедурой AccelerateExcel
    On Error Resume Next
    With Application
        .ScreenUpdating = True 'Включаем обновление экрана после каждого события
        .Calculation = xlCalculationAutomatic 'Расчёты формул - снова в автоматическом режиме
        .EnableEvents = True 'Включаем события
        If Workbooks.Count Then _
            ActiveWorkbook.ActiveSheet.DisplayPageBreaks = True 'Показываем границы ячеек
        .DisplayStatusBar = True 'Возвращаем статусную строку
        .DisplayAlerts = True 'Разрешаем сообшения Excel
    End With
End Sub
 
 Private Sub AccelerateExcel() 'Ускоряем Excel путём отключения всего "тормозящего"
    On Error Resume Next
    With Application
        .ScreenUpdating = False 'Больше не обновляем страницы после каждого действия
        .Calculation = xlCalculationManual 'Расчёты переводим в ручной режим
        .EnableEvents = False 'Отключаем события
        If Workbooks.Count Then _
            ActiveWorkbook.ActiveSheet.DisplayPageBreaks = False 'Не отображаем границы ячеек
        .DisplayStatusBar = False 'Отключаем статусную строку
        .DisplayAlerts = False 'Отключаем сообщения Excel
    End With
 End Sub
 
Sub Найти_number_one()
    Dim r As Range, i&, j&, maxRow&, maxColumn&
    Dim n&
    '
    AccelerateExcel 'Ускоряем работу Excel !
    '
    maxColumn = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
    maxRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
    Set r = Range(Cells(1, 1), Cells(maxRow, maxColumn))
    With Worksheets.Add
        For i = 1 To maxRow: For j = 1 To maxColumn
            If r.Cells(i, j) = "номер один" Or i = 1 Then
                n = n + 1
                r.Range(r.Cells(i, 1), r.Cells(i, maxColumn)).Copy
                .Cells(n, 1).Select
                ActiveSheet.Paste
                Exit For
            End If
        Next: Next
        For i = 1 To maxRow
            .Cells(i, 1).RowHeight = r.Cells(i, 1).RowHeight
        Next
        For j = 1 To maxColumn
            .Cells(1, j).ColumnWidth = r.Cells(1, j).ColumnWidth
        Next
    End With
    '
    disAccelerateExcel 'Восстанавливаем Excel !
    '
End Sub
                        