Sub test2()
    With ActiveCell
        .Value = ChrW(2012) 'вниз
        '.Value = ChrW(2017) 'вверх
        With .Font
            .ThemeColor = xlThemeColorAccent6
            .TintAndShade = -0.249977111117893
        End With
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
End Sub

Sub test2()
    ActiveCell.Select
    
    With Application
        .SendKeys "%{31}"
    End With
    
    With Selection
        With .Font
            .ThemeColor = xlThemeColorAccent6
            .TintAndShade = -0.249977111117893
        End With
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
End Sub

Sub Test1()
    Dim oShape As Shape
    Dim wSt As Worksheet
    Dim cRn As Range, cLL As Range, cCL As Range
    Dim sLt As Single, sTp As Single, sWt As Single, sHt As Single, sXcentre As Single, sYcentre As Single
    Dim cX As Single, cY As Single
    Dim nC As Long, nR As Long
    
    Set wSt = ThisWorkbook.ActiveSheet
    Set cCL = wSt.Cells
    
    For Each oShape In wSt.Shapes
        '1) - пишем в переменные координаты картинки
        With oShape
            sLt = .Left
            sTp = .Top
            sWt = .Width
            sHt = .Height
        End With
        '2) - рассчитываем центр картинки
        sXcentre = sLt + sWt / 2
        sYcentre = sTp + sHt / 2
        '3) - определяем координаты ячейки, по центру которой находится данный рисунок
        '- по X:
        cX = 0
        For Each cLL In cCL.Columns
            cX = cX + cLL.Width
            If cX > sXcentre Then Exit For
        Next
        nC = cLL.Column
        '- по Y:
        cY = 0
        For Each cLL In cCL.Rows
            cY = cY + cLL.Height
            If cY > sYcentre Then Exit For
        Next
        nR = cLL.Row
        '4) - теперь "вяжем" как сказал <<Пытливый>>
        With oShape 'задаем изменять размеры без сохранения пропорции и перемещать с ячейками
            .LockAspectRatio = msoFalse
            .Placement = xlMoveAndSize
'задаем ширину, высоту и привязку верха и левой границы к определенной ячейке
            .Top = Cells(nR, nC).Top
            .Left = Cells(nR, nC).Left
            .Height = Cells(nR, nC).Height
            .Width = Cells(nR, nC).Width
        End With
    Next oShape
End Sub

Sub Get_All_File_from_Folder()
    Dim sFolder As String, sFiles As String
    Dim topT As String
    Dim wbOu As Workbook
    Dim wsOu As Worksheet
    Dim nROu As Long
    Dim wbIn As Workbook
    Dim wsIn As Worksheet
    
    '
    Set wbOu = ActiveWorkbook
    Set wsOu = wbOu.ActiveSheet
    nROu = 3
    
    'диалог запроса выбора папки с файлами
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    'отключаем обновление экрана, чтобы наши действия не мелькали
'    Application.ScreenUpdating = False
    sFiles = Dir(sFolder & "*.xls*")
    Do While sFiles <> ""
        'открываем книгу
        Set wbIn = Application.Workbooks.Open(sFolder & sFiles)
        Set wsIn = wbIn.ActiveSheet
        'действия с файлом
'========================
        nRIn = Range(FindCellIs01_(wsIn, "ОСНОВНЫЕ ХАРАКТЕРИСТИКИ", False)).Row + 1
'Stop
        sborka = ""
        Do
            
            With wsIn
                If sborka = "" Then
                    sborka = .Cells(nRIn, 1).Text & ". " & .Cells(nRIn, 2).Text & " = " & .Cells(nRIn, 3).Text
                Else
                    sborka = sborka & Chr(10) & .Cells(nRIn, 1).Text & ". " & .Cells(nRIn, 2).Text & " = " & .Cells(nRIn, 3).Text
                End If
            End With
            nRIn = nRIn + 1
        Loop While wsIn.Cells(nRIn, 1).Text <> ""
'========================
        'Закрываем книгу
        'wbIn.Close True 'если поставить True - книга будет закрыта с сохранением изменений
        wbIn.Close False 'если поставить False - книга будет закрыта без сохранения изменений
'== записываем собранный результат = In ==
        With wsOu
            .Cells(nROu, 2) = sFiles
            .Cells(nROu, 3) = sborka
        End With
        nROu = nROu + 1
'== записываем собранный результат = Ou ==
        sFiles = Dir
    Loop
    'возвращаем ранее отключенное обновление экрана
'    Application.ScreenUpdating = True
End Sub

Function FindCellIs01_(ByVal wsFind As Worksheet, paramFind As String, ySNo As Boolean)
    'Поиск ячейки с paramFind и нахождение крайней занятой колонки в строке с ней:
    With wsFind.UsedRange
        Set h = .Range(.Cells(1, 1), .Cells(.Row + .Rows.Count - 1, .Column + .Columns.Count - 1)).Find(What:=paramFind)
    End With

    If ySNo = True Then
        With wsFind
            lCol = .Cells(h.Row, Columns.Count).End(xlToLeft).Column
        End With
    End If

    If Not h Is Nothing Then
        If ySNo = True Then
            'сообщаем
            MsgBox "Параметр " & Chr(34) & paramFind & Chr(34) & " находится в ячейке: " & h.Address & Chr(10) & _
                   "крайняя, занятая колонка, в строке с параметром = " & lCol, vbInformation + vbOKOnly, "Ура !!!"
        End If
        'возвращаем
        FindCellIs01_ = h.Address
    Else
        If ySNo = True Then
            'сообщаем
            MsgBox "Параметр " & Chr(34) & paramFind & Chr(34) & Chr(10) & _
                   "НЕ НАЙДЕН!", vbCritical + vbOKOnly, "Караул!!!"
        End If
        'возвращаем
        FindCellIs01_ = ""
   End If
End Function

Sub addHyperLinksInCell()
    'для работы с Опросными листами [ОЛ]
    'устанавливаем Гиперссылку в ячейку на документ [ОЛ] имя которого указано в ячейке
    Dim ws As Worksheet
    Dim pozis As Range
    Dim nR As Long, nC As Long
    Dim zn As String
    Dim pth As String
    Dim tpFl As String
    
    Set ws = ActiveWorkbook.ActiveSheet
    
    pth = "..._Тбл ()\2. ОЛ\"
    tpFl = ".pdf"
    
    With ws
        nR = 7
        nC = 10
        
        Do
            Set pozis = .Cells(nR, nC)
            With pozis
                If .Hyperlinks.Count = 0 Then
                    zn = .Text
                    .Hyperlinks.Add Anchor:=pozis, _
                                    Address:=pth & zn & tpFl, _
                                    TextToDisplay:=zn
                    zn = ""
                End If
            End With
            Set pozis = Nothing
            nR = nR + 1
        Loop While .Cells(nR, nC) <> Empty
    End With

    pth = "": tpFl = ""
    Set ws = Nothing
End Sub

Sub h()
    '===
    Dim blokIn As Range '-
    Dim blokZgl As Range '-
    Dim indd As Range '-
    Dim L As Long '-
    Dim arrNbr '-
    Dim arrNbrTo() '-
    Dim s As String '-
    '===
    Dim Inn As Range '- что ищем
    Dim Start  As Range '-
    
    With ThisWorkbook
        Set blokIn = .Sheets("Данные").Range("C2:C84") ' где искать
        Set blokZgl = .Sheets("Данные").Range("A1:G1") ' заголовки таблицы данных
        Set Inn = .Sheets("Вывод").Range("E4") ' что ищем -> Идентификатор
        Set Start = .Sheets("Вывод").Range("B13") ' откуда начинаем вставлять
    End With
    
    'структура выводимого блока данных:
    s = "№;ФИО;телефон;город"
    arrNbr = Split(s, ";", , vbTextCompare) '- задаем массивом структуру выводимого блока данных
    
    'итак: _
     просматриваем лист "Данные", находим Идентификатор Inn
    L = 0 'счетчик = 0
    For Each indd In blokIn 'из блока ячеек "где искать", очередная ячейка
        If indd.Text = Inn.Text Then 'если текст в ячейке = текст в ячейке "что ищем", то
            '
            If L = 0 Then
                'создаем новый двумерный массив
                ReDim arrNbrTo(0 To UBound(arrNbr), 0 To L)
            Else '
                'увеличиваем крайнюю [0 To L] размерность двумерного массива, с сохранением [Preserve] предыдущих записей
                ReDim Preserve arrNbrTo(0 To UBound(arrNbr), 0 To L)
            End If
            'пишем в созданный массив данные из найденной записи, согласно структуры выводного блока данных
            'для чего, просматриваем массив структуры и,
            For i = LBound(arrNbr) To UBound(arrNbr)
                'блок ячеек заголовка
                For Each ttt In blokZgl
                    'если значения совпали, то
                    If ttt.Text = arrNbr(i) Then
                        'пишем в массив
                        arrNbrTo(i, L) = ThisWorkbook.Sheets("Данные").Cells(indd.Row, ttt.Column).Text
                        'выходим из просмотра блока ячеек заголовка
                        Exit For
                    End If
                Next
            Next i
            'счетчик +1
            L = L + 1
        End If
    Next
    Erase arrNbr '- удаляем массив структуры
    
    If (Not Not arrNbrTo) <> 0 Then
        ' Массив был инициализирован, так что все готово. [Array has been initialized, so you're good to go.]
        'пишем собранные данные в блок листа "Вывод"
        For i = LBound(arrNbrTo, 2) To UBound(arrNbrTo, 2)
            For j = LBound(arrNbrTo, 1) To UBound(arrNbrTo, 1)
                Start.Offset(i, j) = arrNbrTo(j, i)
            Next j
        Next i
        Erase arrNbrTo '- очищаем двумерный масси данных
    Else
        ' Массив НЕ был инициализирован [Array has NOT been initialized]
        MsgBox "Записей, по данному Идентификатору" & Chr(10) & _
               "НЕ ОБНАРУЖЕНО.", vbCritical + vbOKOnly, "Идентификатор: " & Inn
        Exit Sub
    End If
End Sub

'Поиск ячейки с "01_" и нахождение крайней занятой колонки в строке с ней:
   With Sheets("Лист1")
       Set h = .Range(.Cells(1, 1), .Cells(10, .UsedRange.Column + .UsedRange.Columns.Count - 1)).Find(What:="01_")
       lCol = .Cells(h.Row, Columns.Count).End(xlToLeft).Column
   End With
   'сообщаем
   If Not h Is Nothing Then
        MsgBox "Параметр 01_ находится в ячейке: " & h.Address & Chr(10) & _
               "крайняя, занятая колонка, в строке с параметром = " & lCol
   End If

Sub test()
    nRIn = Range(FindCellIs01_(ActiveSheet, "01_", False)).Row
    nROu = Range(FindCellIs01_(ActiveSheet, "Итого:", False)).Row
    
    MsgBox "- начала блока = " & nRIn & Chr(10) & "- окончания блока = " & nROu, vbInformation + vbOKOnly, "номер строки:"
End Sub

Function FindCellIs01_(ByVal wsFind As Worksheet, paramFind As String, ySNo As Boolean)
    'Поиск ячейки с paramFind и нахождение крайней занятой колонки в строке с ней:
    With wsFind.UsedRange
        Set h = .Range(.Cells(1, 1), .Cells(.Row + .Rows.Count - 1, .Column + .Columns.Count - 1)).Find(What:=paramFind)
    End With

    If ySNo = True Then
        With wsFind
            lCol = .Cells(h.Row, Columns.Count).End(xlToLeft).Column
        End With
    End If

    If Not h Is Nothing Then
        If ySNo = True Then
            'сообщаем
            MsgBox "Параметр " & Chr(34) & paramFind & Chr(34) & " находится в ячейке: " & h.Address & Chr(10) & _
                   "крайняя, занятая колонка, в строке с параметром = " & lCol, vbInformation + vbOKOnly, "Ура !!!"
        End If
        'возвращаем
        FindCellIs01_ = h.Address
    Else
        If ySNo = True Then
            'сообщаем
            MsgBox "Параметр " & Chr(34) & paramFind & Chr(34) & Chr(10) & _
                   "НЕ НАЙДЕН!", vbCritical + vbOKOnly, "Караул!!!"
        End If
        'возвращаем
        FindCellIs01_ = ""
   End If
End Function

Private Sub Закончить_Click()
...
    perenos s, nomZak, ws_P
    Set ws_P = Nothing: s = "" ': nomZak = ""
...
End Sub