Public Sub a()
     Dim x&, yy&, y&
     On Error Resume Next
     x = Sheets("Лист2").Cells.Find("*", [a1], xlFormulas, 1, 2, 2).Column    ' + 1
     y = Cells(Rows.Count, 7).End(xlUp).Row    ' тянем формулу по 7-му столбцу
     If IsDate(Cells(3, x).Value) Then
         Range(Cells(4, x), Cells(y, x)).Formula = _
         "=INDEX(Лист1!R1:R65536, MATCH(RC7,Лист1!C3,), MATCH(R3C,Лист1!R5,))"
         Range(Cells(4, x), Cells(y, x)).Value = Range(Cells(4, x), Cells(y, x)).Value
         For yy = 4 To Cells(Rows.Count, 7).End(xlUp).Row
             If Cells(yy, x - 1).Value <> Cells(yy, x).Value Then
                 Cells(yy, 8).Value = Cells(yy, x).Value
             End If
         Next
     Else: MsgBox ("проверь дату")
     End If
End Sub

Public Sub a()
       Dim x&, yy&, y&, a, b, s
       On Error Resume Next
       a = Array("стабильное", "нестабильное", "удовлетворительное", "неудовлетворительное", "критическое")
       x = Sheets("Лист2").Cells.Find("*", [a1], xlFormulas, 1, 2, 2).Column    ' + 1
       y = Cells(Rows.Count, 7).End(xlUp).Row    ' тянем формулу по 7-му столбцу
       If Cells(3, x).Value<>"" Then
           Range(Cells(4, x), Cells(y, x)).Formula = _
           "=INDEX(Лист1!R1:R65536, MATCH(RC7,Лист1!C3,), MATCH(R3C,Лист1!R5,))"
           Range(Cells(4, x), Cells(y, x)).Value = Range(Cells(4, x), Cells(y, x)).Value
           For yy = 4 To Cells(Rows.Count, 7).End(xlUp).Row
               For i = 0 To 5
                   Select Case a(i) = Cells(yy, x - 1).Value
                   Case True
                       b = i
                   End Select
               Next
               For i = 0 To 5
                   Select Case a(i) = Cells(yy, x).Value
                   Case True
                       s = i
                   End Select
               Next
               If b = s Then: Cells(yy, 8).Value = "без изменений"
               If b < s Then: Cells(yy, 8).Value = "ухудшилось"
               If b > s Then: Cells(yy, 8).Value = "улучшилось"
           Next
       Else: MsgBox ("поставьте дату")
       End If
End Sub

Sub qqq()
     Application.ScreenUpdating = False
     With Workbooks.Open(ThisWorkbook.Path & "\Книга 2.xlsx")
         .Sheets(1).Range("C4").End(xlToRight).Offset(, 1).Resize(72, 6).Value = _
         ThisWorkbook.Sheets(1).Range("C4").Resize(72, 6).Value
         .Close True
     End With
     Application.ScreenUpdating = True
End Sub