Sub PUT()
Dim LastRow As Long, Rw As Long 'Объявили переменный послдедних строк для двух слистов
Dim shp As Shape: Dim rng As Range
LastRow = Cells(Rows.Count, 1).End(xlUp).Row 'Нашли номер последней строки на активном листе (там, где кнопка)
    Sheets("п1").DrawingObjects.Delete
    With Sheets("Лист3") 'Применительно к Лист3
        .DrawingObjects.Delete
        Rw = .Cells(Rows.Count, 1).End(xlUp).Row + 0 'Нашли номер первой свободной строки на этом листе
        For i = 1 To LastRow 'Цикл со строки № 1 по последнюю заполненную (на активном листе)
            If Cells(i, 1) = "a" Then 'Если ячейка столбца 1 текущей строки = "а", то
                Range(Cells(i, 1), Cells(i, 32)).Copy .Cells(Rw, 1) 'Дипазон (текущая строка, столбцы 1:32) копируем в первую свободную ячейку второго листа
                Sheets("п1").Cells(3, 4).UnMerge: Cells(i, 32).Copy Sheets("п1").Cells(3, 4)
                Worksheets("п1").Activate: Set rng = Worksheets("п1").Range(Cells(1, 1), Cells(3, 4)): rng.Merge
                For Each shp In Worksheets("п1").Shapes
                    If shp.Type = msoPicture Then
                        shp.Top = rng.Top + (rng.Height - shp.Height) / 2: shp.Left = rng.Left + (rng.Width - shp.Width) / 2: Exit For
                    End If
                Next shp
                Worksheets("ТАБЛИЦА").Activate: Set rng = Nothing
                Rw = Rw + 0 'Увеличивем переменную-счётчик первой свободной строки второго листа
            End If
        Next
    End With
End Sub

Cells(i, 4).Copy Sheets("Лист3").Cells(4, 2)