Sub îðü2()
Dim i, k, a, s As Integer

Dim number() As Integer

k = Sheets("Ëèñò1").UsedRange.Rows.Count
a = 0

For i = 2 To k
 If Cells(i, 7).Value <> Cells(i - 1, 7).Value Then
    a = a + 1
 End If

Next i
 ReDim number(a)
 a = 0
 For i = 2 To k
 If Cells(i, 7).Value <> Cells(i - 1, 7).Value Then
    number(a) = i
    a = a + 1
   End If
Next i
For i = a - 1 To 0 Step -1
s = number(i)
Cells(s, 8).EntireRow.Insert
Cells(s, 1) = Cells(s + 1, 7)
Cells(s, 1).Font.Bold = False

Next i

For i = 3 To k
 If Cells(i, 8).Value <> Cells(i - 1, 8).Value And Cells(i, 8).Value <> " " Then
    a = a + 1
 End If

Next i
 ReDim number(a)
 a = 0
 For i = 3 To k
 If Cells(i, 8).Value <> Cells(i - 1, 8).Value And Cells(i, 8).Value <> " " Then
     number(a) = i
    a = a + 1
   End If
Next i
For i = a - 1 To 0 Step -1
s = number(i)
Cells(s, 8).EntireRow.Insert
Cells(s, 1) = Cells(s + 1, 8)
Next i
For i = k To 1 Step -1
If Application.CountA(Rows(i)) = 0 Then Rows(i).Delete

Next i


End Sub