Sub Perenos()
Const H = "H"
Dim j As Variant
Dim iLR_A As Long
Dim iLastRow As Long
  For Each j In Array(2, 4)
    iLR_A = Cells(Rows.Count, H).End(xlUp).Row + 1
    iLastRow = Cells(Rows.Count, j).End(xlUp).Row
    Range(Cells(1, j), Cells(iLastRow, j)).Cut Cells(iLR_A, H)
  Next
  iLR_A = Cells(Rows.Count, H).End(xlUp).Row
  For j = iLR_A To 1 Step -1
    If IsEmpty(Cells(j, H)) Then Rows(j).Delete
  Next
End Sub

Sub Perenos()
Dim j As Integer
Dim iLR_A As Long
Dim iLastRow
  For j = 2 To 5
    iLR_A = Cells(Rows.Count, "A").End(xlUp).Row + 1
    iLastRow = Cells(Rows.Count, j).End(xlUp).Row
    Range(Cells(1, j), Cells(iLastRow, j)).Cut Cells(iLR_A, 1)
  Next
  iLR_A = Cells(Rows.Count, "A").End(xlUp).Row
  For j = iLR_A To 1 Step -1
    If IsEmpty(Cells(j, 1)) Then Rows(j).Delete
  Next
End Sub

Sub Протянуть_формулу()
    With Sheets("Лист1")
    [C8].Resize(Cells(Rows.Count, "B").End(xlUp).Row - 7, 1).FormulaR1C1 = "=IF(RC[-1]=1,""Нет"",""Да"")"
        End With
End Sub

Sub Кнопка1_Щелчок()
If InputBox("Введите пароль") <> "123" Then MsgBox "неправильный пароль": Exit Sub
Ваш макрос
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cl As Range
If Not Intersect(Target, [A1:C20]) Is Nothing Then
On Error Resume Next
For Each cl In Sheets("Лист2").Range("A1:A6").Cells
N = WorksheetFunction.Search(cl.Text, Target)
If Err = 0 Then
With Target.Characters(N, Len(cl)).Font

.FontStyle = "полужирный"

End With
Else
Err.Clear
End If
Next
End If
End Sub