Application.ScreenUpdating = False:

Sub RemoveRows()
Dim Rg1 As Range
Set Rg1 = Cells(Rows.Count, 1).End(xlUp)
For i = Rg1.Row To 2 Step -1
If InStr(1, Cells(i, 1), ",", vbTextCompare) Then
i = i - 3
Else
    Select Case Cells(i, 1)
Case "СРОЧНО"
Case "*****": If Cells(i + 1, 1) = "СРОЧНО" Then Rows(i).Delete Else Cells(i, 1).ClearContents
Case "": Rows(i).Delete
Case Else
        Rows(i).Delete
    End Select
End If
Next i
End Sub

Sub Remove1()
Dim Rg1 As Range
Application.ScreenUpdating = 0
Set Rg1 = Cells(Rows.Count, 1).End(xlUp)
For i = Rg1.Row To 2 Step -1
If InStr(1, Cells(i, 1), ",", vbTextCompare) Then
i = i - 3
Else
    Select Case Cells(i, 1)
Case "СРОЧНО"
Case "*****": If Cells(i + 1, 1) = "СРОЧНО" Then Cells(i, 1).Delete (xlUp) Else Cells(i, 1).ClearContents
Case "": Cells(i, 1).Delete (xlUp)
Case Else
        Cells(i, 1).Delete (xlUp)
    End Select
End If
Next i
End Sub

Sub ww()
Dim rng As Range
Dim iLastRow As Long
Dim iLR As Long
Dim Kol As Integer
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Range("C2:C" & iLastRow).ClearContents
  For Each rng In Range("A2:A" & iLastRow).SpecialCells(2, 3).Areas
    Kol = WorksheetFunction.CountIf(rng, "СРОЧНО")
    If Kol Then
      iLR = Cells(Rows.Count, "C").End(xlUp).Row + 1
      Cells(iLR, "C") = "СРОЧНО"
      iLR = iLR + 1
    Else
      iLR = Cells(Rows.Count, "C").End(xlUp).Row + 2
    End If
      Range(rng.Cells(rng.Count - 3), rng.Cells(rng.Count)).Copy Cells(iLR, "C")
  Next
End Sub