dim adr, c&
adr = array("A2", "G10", "H3" ... "Y8") ' тут не вижу закономерности в указанных адресах, поэтому... простым перечислением имен ячеек
...
for c = 0 to ubound(adr)
  cells(3,1+c) = range(adr(c))
next

If Not Intersect(Target, Range("A1:AB20")) Is Nothing Then

Range("ACE3").Value = Range("A2").Value
Range("ACF3").Value = Range("G10").Value
Range("ACG3").Value = Range("H3").Value
.
.
.
Range("BHZ3").Value = Range("Y8").Value

Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim FilterCol As Integer
    Dim FilterRange As Range
    Dim CondtitionString As Variant
    Dim Condition1 As String, Condition2 As String
 
    If Intersect(Target, Range("A2:BZS2")) Is Nothing Then Exit Sub
 
    On Error Resume Next
    Application.ScreenUpdating = False
     
    Set FilterRange = Target.Parent.AutoFilter.Range
     
    For Each cell In Target.Cells
        FilterCol = cell.Column - FilterRange.Columns(1).Column + 1
         
        If IsEmpty(cell) Then
            Target.Parent.Range(FilterRange.Address).AutoFilter Field:=FilterCol
        Else
            If InStr(1, UCase(cell.Value), " ÈËÈ ") > 0 Then
                LogicOperator = xlOr
                ConditionArray = Split(UCase(cell.Value), " ÈËÈ ")
            Else
                If InStr(1, UCase(cell.Value), " È ") > 0 Then
                    LogicOperator = xlAnd
                    ConditionArray = Split(UCase(cell.Value), " È ")
                Else
                    ConditionArray = Array(cell.Text)
                End If
            End If
            If Left(ConditionArray(0), 1) = "<" Or Left(ConditionArray(0), 1) = ">" Then
                Condition1 = ConditionArray(0)
            Else
                Condition1 = "=" & ConditionArray(0)
            End If
            If UBound(ConditionArray) = 1 Then
                If Left(ConditionArray(1), 1) = "<" Or Left(ConditionArray(1), 1) = ">" Then
                    Condition2 = ConditionArray(1)
                Else
                    Condition2 = "=" & ConditionArray(1)
                End If
            End If
            If UBound(ConditionArray) = 0 Then
                Target.Parent.Range(FilterRange.Address).AutoFilter Field:=FilterCol, Criteria1:=Condition1
            Else
                Target.Parent.Range(FilterRange.Address).AutoFilter Field:=FilterCol, Criteria1:=Condition1, _
                    Operator:=LogicOperator, Criteria2:=Condition2
            End If
        End If
    Next cell
     
    Set FilterRange = Nothing
    Application.ScreenUpdating = True
End Sub

Sub Add_Row()
    Dim sSubStr As String
    Dim lCol As Long
    Dim lLastRow As Long, li As Long
    Dim lMet As Long
    Dim arr
 
    sSubStr = "10" 'Число
    If sSubStr = "" Then lMet = 0 Else lMet = 1
    lCol = "2" 'Столбец
    If lCol = 0 Then Exit Sub
 
    lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
    arr = Cells(1, lCol).Resize(lLastRow).Value
    Application.ScreenUpdating = 0
    Dim rr As Range
    For li = 1 To lLastRow
        If -(InStr(arr(li, 1), sSubStr) > 0) = lMet Then
            If rr Is Nothing Then
                Set rr = Cells(li, 1)
            Else
                Set rr = Union(rr, Cells(li, 1))
            End If
        End If
    Next li
    If Not rr Is Nothing Then rr.EntireRow.Insert
    Application.ScreenUpdating = 1
End Sub

Sub ReplacePart()
Dim a, shReplace As Worksheet, sh, i As Long, j As Long, r As Long, oldPart, newPart
Set shReplace = Sheets("Замена")
r = 2
Do
  oldPart = shReplace.Cells(r, 1)
  newPart = shReplace.Cells(r, 2)
  For Each sh In Worksheets
    If sh.Name <> shReplace.Name Then
      With sh
        .Cells.Replace What:=oldPart, Replacement:=newPart, _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
        SearchFormat:=False, ReplaceFormat:=False
      End With
    End If
  Next
  r = r + 1
Loop Until shReplace.Cells(r, 1) = ""
End Sub

iRed.Offset(1, "Первая колонка" ).Resize(.Rows.Count - iRed.Row + .Row - 1, .Columns.Count).ClearContents

Do
        iRed.Offset(1).Resize(.Rows.Count - iRed.Row + .Row - 1).ClearContents

Sub Delete_Red()
'
Dim i&
Dim n As Boolean
n = False
With Sheets("Test 1")
    For i = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
' From A3 to H24
        If .Cells(i, 5) = "Розовый" Then
            With .Range(.Cells(i, 3), .Cells(i, 4))
                .ClearContents
            End With
        End If
        If .Cells(i, 8) = "Розовый" Then
            With .Range(.Cells(i, 6), .Cells(i, 7))
                .ClearContents
            End With
        End If
        If .Cells(i, 5) = "Красный" Or .Cells(i, 8) = "Красный" Then
            With .Range(.Cells(i + 1, 1), Cells(24, 8))
                .ClearContents
            End With
        End If
        
 ' From A26 to H47
 
        If .Cells(i, 5) = "Розовый" Then
            With .Range(.Cells(i, 3), .Cells(i, 4))
                .ClearContents
            End With
        End If
        If .Cells(i, 8) = "Розовый" Then
            With .Range(.Cells(i, 6), .Cells(i, 7))
                .ClearContents
            End With
        End If
        If .Cells(i, 5) = "Красный" Or .Cells(i, 8) = "Красный" Then
            With .Range(.Cells(i + 1, 1), Cells(47, 8))
                .ClearContents
            End With
        End If
    Next i
End With
End Sub