'Option Base 1
Option Explicit
'Option Private Module
'==================================================================================================
Sub Splitter()
Dim rng As Range
Dim x, arr, aCrit(), aOne(1 To 1, 1 To 1)
Dim tx$, t!, r&, m&, nSpl&, f As Boolean

t = Timer
Set rng = [a2:a88]: arr = rng.Value2
ReDim Preserve arr(1 To UBound(arr, 1), 1 To 2)
aCrit = Array("шумоглушитель *", "гибкая вставка *", "вентилятор канальный *", "обратный клапан *", "регулятор скорости *")

For r = 1 To UBound(arr, 1)
    tx = LCase$(Trim(arr(r, 1)))

    For Each x In aCrit
        If tx Like x Then f = True: Exit For
    Next x

    If f Then
        f = False: nSpl = nSpl + 1: m = Len(x)
        arr(r, 2) = Trim(Mid$(arr(r, 1), m)): arr(r, 1) = Trim(Left$(arr(r, 1), m - 2))
    End If
Next r

If nSpl = 0 Then MsgBox "Строк для разделения НЕ НАЙДЕНО!", vbExclamation, "Время работы: " & Format$(Timer - t, "0.00 сек"): Exit Sub

rng.Resize(UBound(arr, 1), UBound(arr, 2)).Value2 = arr
MsgBox "Разделено строк: " & Format$(nSpl, "#,##0") & " из " & UBound(arr, 1), vbInformation, "Время работы: " & Format$(Timer - t, "0.00 сек")
End Sub
'==================================================================================================
'==================================================================================================

Sub t()
Dim x, aMask()

aMask = Array("*приточная*", "*вытяжная*", "*установка*", "*id*")

For Each x In aMask
    Debug.Print LCase$("автоматическая Установка на работе") Like x
Next x
End Sub

Dim i&
arr = Array("было1", "стало1", "было2", "стало2")

For i = LBound(arr) To UBound(arr) Step 2
    Cells.Replace What:=arr(i), Replacement:=arr(i + 1), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Next i

Option Explicit
'==================================================================================================
' вместо этого
Cells.Replace What:="G3 SFPKU 400?200", Replacement:="G3 DV-M01000 FLFU", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="G3 SFPKU 500?250", Replacement:="G3 DV-M02000 FLFU", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="G3 SFPKU 500?300", Replacement:="G3 DV-M02500 FLFU", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="G3 SFPKU 600?300", Replacement:="G3 DV-M03000 FLFU", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="G3 SFPKU 600?350", Replacement:="G3 DV-M04000 FLFU", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="G3 SFPKU 700?400", Replacement:="G3 DV-M06200 FLFU", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="G3 SFPKU 800?500", Replacement:="G3 DV-M07000 FLFU", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="G3 SFPKU 900?500", Replacement:="G3 DV-M08500 FLFU", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="G3 SFPKU 1000?500", Replacement:="G3 DV-M12000 FLFU", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False


' можно так
Dim arr(1 To 9, 1 To 2), r&

arr(1, 1) = "G3 SFPKU 400?200": arr(1, 2) = "G3 DV-M01000 FLFU"
arr(2, 1) = "G3 SFPKU 500?250": arr(2, 2) = "G3 DV-M02000 FLFU"
arr(3, 1) = "G3 SFPKU 500?300": arr(3, 2) = "G3 DV-M02500 FLFU"
arr(4, 1) = "G3 SFPKU 600?300": arr(4, 2) = "G3 DV-M03000 FLFU"
arr(5, 1) = "G3 SFPKU 600?350": arr(5, 2) = "G3 DV-M04000 FLFU"
arr(6, 1) = "G3 SFPKU 700?400": arr(6, 2) = "G3 DV-M06200 FLFU"
arr(7, 1) = "G3 SFPKU 800?500": arr(7, 2) = "G3 DV-M07000 FLFU"
arr(8, 1) = "G3 SFPKU 900?500": arr(8, 2) = "G3 DV-M08500 FLFU"
arr(9, 1) = "G3 SFPKU 1000?500": arr(9, 2) = "G3 DV-M12000 FLFU"

For r = 1 To UBound(arr, 1)
    Cells.Replace arr(r, 1), arr(r, 2), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Next r
'==================================================================================================
' вместо этого
Set MR = Range("A1:H4000")

For Each cell In MR
    If cell.Value = "" Then cell.EntireRow.Delete
Next

For Each cell In MR
    If cell.Value = "" Then cell.EntireRow.Delete
Next

For Each cell In MR
    If cell.Value = "" Then cell.EntireRow.Delete
Next

For Each cell In MR
    If cell.Value = "" Then cell.EntireRow.Delete
Next


' можно так
Dim cl As Range, gr As Range, tx$

tx = "%%%Итого (оборудование)%%%Итого (КИПиА)Итого%%%КИПиА%%%"

For Each cl In Range("A1:H4000").Cells
    If tx Like "*%%%" & cl.Value & "%%%*" Then
        If gr Is Nothing Then Set gr = cl Else Set gr = Union(rg, cl)
    End If
Next cl

If Not gr Is Nothing Then gr.EntireRow.Delete

'==================================================================================================
' вместо этого
Cells.Replace What:="SVOK", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="RUB", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="??", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False


' можно так
Dim x

For Each x In Array("SVOK", "RUB", "??")
   Cells.Replace x, "", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Next x
'==================================================================================================