Sub середина1()

' Сочетание клавиш: Ctrl+q

    Application.DisplayAlerts = False
    sb = Selection.Column
    st = Selection.Row
    If Cells(st, sb - 1) = "" Then
        MsgBox "Внимание! Левый столбец ПУСТ!", vbInformstion, "Конец фильма"
        Exit Sub
    End If
    psp = Cells(Application.Rows.Count, sb).End(xlUp).Row
        psl = Cells(psp, sb - 1).End(xlUp).Row
        ns = psl - 1
    
    For i = psp To st Step -1
        c = ""
        tk = psp - psl + 1
        c = Fix(tk / 2)
        Cells(psl + c - 1, sb - 1) = Cells(psl, sb - 1)
        Cells(psl, sb - 1) = ""

        Cells(psl + c - 1, sb - 1).VerticalAlignment = xlCenter
        Cells(psl + c - 1, sb - 1).HorizontalAlignment = xlCenter
        
        p = psl - 1
        psl = Cells(psl, sb - 1).End(xlUp).Row
        i = psl + 1
        psp = p
    If psp = 0 Then
    Application.DisplayAlerts = True
        Exit Sub
    End If
    Next i
    Application.DisplayAlerts = True
End Sub

Sub ToCentre()
  Dim Lr&, R&, R1&, rg As Range
  Lr = ActiveCell.End(xlDown).Row :  Set rg = ActiveCell.Offset(0, -1)
  Do While R < Lr
    If Not IsEmpty(rg.Offset(1, 0)) Then R = rg.Row + 1 Else R = rg.End(xlDown).Row - 1: If R > Lr Then R = Lr
    If R - rg.Row > 3 Then
      R1 = Int((rg.Row + R) / 2): Cells(R1, 1) = rg:  Cells(R1, 9) = rg.Offset(0, 8)
      rg = Empty:  rg.Offset(0, 8) = Empty
    End If
    Set rg = Cells(R, 1)
  Loop
End Sub