Sub Макрос2()

Dim Arr1 As Variant, Arr2 As Variant, Arr3 As Variant
Dim n As Integer, m As Integer, x As Integer, y As Integer, Lr1 As Integer, Lr2 As Integer
Dim sl As String

Lr1 = Workbooks("База.xlsm").Worksheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row
Arr1 = Workbooks("База.xlsm").Worksheets("Лист1").Range("A1:AN" & Lr1)

Lr2 = Workbooks("Шаблон_1.xlsx").Worksheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row
Arr2 = Workbooks("Шаблон_1.xlsx").Worksheets("Лист1").Range("A1:AN" & Lr2)

If Not Lr1 = Lr2 Then MsgBox "Количество строк в Базе 1 не равно количеству строк в Базе 2": Exit Sub

For n = 1 To UBound(Arr2, 1)
    For m = 1 To UBound(Arr2, 2)
        If Arr2(n, m) = "ИП Детсво" Then
            For x = 1 To UBound(Arr1, 2)
                If Arr1(n, x) = "ИП Детсво" Then
                    If x > m Then
                        For y = m To UBound(Arr1, 2)
                            If y < x Then
                                Arr1(n, y) = ""
                            Else
                                Arr1(n, m + (y - x)) = Arr1(n, y)
                                Arr1(n, y) = ""
                            End If
                        Next y
                    End If
                Exit For
                End If
            Next x
            Exit For
        End If
    Next m
Next n

Workbooks("База.xlsm").Worksheets("Результат").Range("A1:AN" & Lr1) = Arr1
Sheets("Результат").Select

End Sub