Function Интерполяция(ДиапазонA As String, ДиапазонB As String, ДиапазонДанных As String, F19 As Double, F22 As Double, F24 As Double) As Variant
 Dim A As Range, B As Range, Data As Range
 Dim TargetValue As Double
 Dim MinA As Double, MaxA As Double
 Dim RowIndex As Long, ColIndex As Long
 Dim MinB As Double, MaxB As Double
 Dim ColIndexMax As Long
 Dim Y1 As Double, Y2 As Double
 Dim MinA_found As Boolean, MinB_found As Boolean, MaxB_found As Boolean

 ' Устанавливаем диапазоны
 On Error Resume Next
 Set A = Range(ДиапазонA)
 Set B = Range(ДиапазонB)
 Set Data = Range(ДиапазонДанных)
 On Error GoTo 0

 ' Проверяем, что диапазоны корректны
 If A Is Nothing Or B Is Nothing Or Data Is Nothing Then
 Интерполяция = CVErr(xlErrRef) ' Возвращаем ошибку ссылки
 Exit Function
 End If

 ' Проверяем, что все значения числовые
 If Application.WorksheetFunction.Count(A) <> A.Count Or _
 Application.WorksheetFunction.Count(B) <> B.Count Or _
 Application.WorksheetFunction.Count(Data) <> Data.Count Then
 Интерполяция = CVErr(xlErrValue) ' Возвращаем ошибку значения
 Exit Function
 End If

 ' Рассчитываем целевое значение
 TargetValue = Application.WorksheetFunction.Average(F22, F24)

 ' Находим минимальное значение в A, которое больше или равно F19
 On Error Resume Next
 MinA = Application.WorksheetFunction.Min(Evaluate("IF(" & ДиапазонA & ">=" & F19 & "," & ДиапазонA & ", """")"))
 RowIndex = Application.Match(MinA, A, 0)
 On Error GoTo 0

 ' Проверяем, чтобы RowIndex был валиден
 If RowIndex <= 0 Or RowIndex > A.Rows.Count Then
 Интерполяция = CVErr(xlErrValue)
 Exit Function
 End If

 ' Находим минимальное значение в B, которое больше или равно TargetValue
 On Error Resume Next
 MinB = Application.WorksheetFunction.Min(Evaluate("IF(" & ДиапазонB & ">=" & TargetValue & "," & ДиапазонB & ", """")"))
 ColIndex = Application.Match(MinB, B, 0)
 On Error GoTo 0

 ' Проверяем, чтобы ColIndex был валиден
 If ColIndex <= 0 Or ColIndex > B.Columns.Count Then
 Интерполяция = CVErr(xlErrValue)
 Exit Function
 End If

 ' Находим максимальное значение в B, которое меньше или равно TargetValue
 On Error Resume Next
 MaxB = Application.WorksheetFunction.Max(Evaluate("IF(" & ДиапазонB & "<=" & TargetValue & "," & ДиапазонB & ", """")"))
 ColIndexMax = Application.Match(MaxB, B, 0)
 On Error GoTo 0

 ' Проверяем, чтобы ColIndexMax был валиден
 If ColIndexMax <= 0 Or ColIndexMax > B.Columns.Count Then
 Интерполяция = CVErr(xlErrValue)
 Exit Function
 End If

 ' Получаем значения для интерполяции
 Y1 = Data.Cells(RowIndex, ColIndex)
 Y2 = Data.Cells(RowIndex, ColIndexMax)

 ' Проверяем, что TargetValue находится между MinB и MaxB
 If TargetValue < MinB Or TargetValue > MaxB Then
 Интерполяция = CVErr(xlErrValue) ' Возвращаем ошибку значения
 Exit Function
 End If

 ' Интерполяция
 Интерполяция = Y1 + ((TargetValue - MinB) / (MaxB - MinB)) * (Y2 - Y1)
End Function

Option Explicit

Public Function РАЗДЕЛИТЬ(Строка As String, Индекс_начало As Long, Индекс_конец As Long) As Variant
    Const DLM = "-"
    If InStr(Строка, DLM) = 0 Then
        РАЗДЕЛИТЬ = Строка
    Else
        Dim arr As Variant
        arr = Split(Строка, DLM)
        
        ReverseIndex Индекс_начало, UBound(arr)
        ReverseIndex Индекс_конец, UBound(arr)
        
        Dim brr As Variant
        ReDim brr(Индекс_начало To Индекс_конец)
        
        Dim yb As Long
        For yb = LBound(brr) To UBound(brr)
            brr(yb) = arr(yb)
        Next
        
        РАЗДЕЛИТЬ = Join(brr, DLM)
    End If
End Function

Private Sub ReverseIndex(ind As Long, iUbo As Long)
    If ind < 0 Then
        ind = iUbo + ind + 1
    Else
        ind = ind - 1
    End If
End Sub

Private Sub Workbook_Open()
On Error Resume Next
Application.OnKey "^ч", "enstaralfgdf"
Application.OnKey "^x", "enstaralfgdf"

End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.OnKey "^ч", ""
Application.OnKey "^x", ""
End Sub

Sub enstaralfgd() ' Поиск значений на листе
Dim Rg1 As Range, Rg2 As Range, Rg3 As Range, Rg4 As Range, FindText$, Adres$
Application.ScreenUpdating = False ' отключаем обновление экрана
FindText = "Для заказчика" ' ищем ячейки с таким текстом
    Set Rg1 = ActiveSheet.UsedRange
     
    Set Rg2 = Rg1.Find(FindText, , xlValues, xlWhole) 'Краткая запись для поиска
If Not Rg2 Is Nothing Then 'After можно не указывать
        Adres$ = Rg2.Address
        Do
        Set Rg3 = Rg2.CurrentRegion.Columns(Rg2.Column)
        For I = 1 To Rg3.Cells.Count
If Rg3.Cells(I) = "" Then
    If Rg4 Is Nothing Then Set Rg4 = Rg2.Cells(I) Else Set Rg4 = Union(Rg4, Rg2.Cells(I))
End If
        Next
            Set Rg2 = Rg1.Cells.FindNext(After:=Rg2)
        Loop Until Rg2.Address = Adres
End If
Rg4.EntireRow.Delete
End Sub

Sub DelLine()
  Dim i As Long
  Dim diapaz1 As Range
  Dim diapaz2 As Range
Set diapaz1 = Application.Range(ActiveSheet.Range("A1"), _
ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
For i = 1 To diapaz1.Rows.Count
If WorksheetFunction.CountA(diapaz1.Rows(i).EntireRow) = 0 Then
If diapaz2 Is Nothing Then
Set diapaz2 = diapaz1.Rows(i).EntireRow
Else
Set diapaz2 = Application.Union(diapaz2, diapaz1.Rows(i).EntireRow)
End If
End If
Next
If diapaz2 Is Nothing Then
MsgBox "Не найдено ни одной пустой строки!"
Else
diapaz2.[Delete]
End If
End Sub

Sub КопированиеДанных()
    Dim wbNew As Workbook
    Dim wsSource As Worksheet
    Dim LastRow As Long
    Dim Rng As Range
     
    Application.ScreenUpdating = False
     
    Set wsSource = ThisWorkbook.Worksheets("Сравнение")
     
    With wsSource
        If .FilterMode = True Then .ShowAllData
        LastRow = .Cells(.Rows.Count, "G").End(xlUp).Row
        Set Rng = .Range("B1:G" & LastRow).SpecialCells(12)
    End With
     
    Set wbNew = Workbooks.Add(xlWBATWorksheet)
     
    With wbNew.Worksheets(1)
        Rng.Copy
        .Range("A1").PasteSpecial xlPasteValues 'копируем значения
        .Range("A1").PasteSpecial xlPasteFormats 'копируем формат
        .Range("A1").PasteSpecial Paste:=xlPasteColumnWidths 'корпируем ширину столбцов
        Set Rng = wsSource.Range("E1:E" & LastRow).SpecialCells(12)
        Rng.Copy Destination:=.Range("D1")
        Set Rng = wsSource.Range("G1:G" & LastRow).SpecialCells(12)
        Rng.Copy Destination:=.Range("F1")
        .UsedRange.EntireRow.AutoFit 'выравнивание высоты строки
        .Rows(1).Font.Bold = True
        .Rows(1).WrapText = True
        .Rows(1).VerticalAlignment = xlCenter
        .Rows(1).HorizontalAlignment = xlCenter
        .Cells(1, 1).Select
        .Name = "Сравнение"
    End With
     
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Sub КопированиеДанных()
    Dim wbNew As Workbook
    Dim wsSource As Worksheet
    Dim LastRow As Long
    Dim Rng As Range
     
    Application.ScreenUpdating = False
     
    Set wsSource = ThisWorkbook.Worksheets("Сравнение")
     
    With wsSource
        If .FilterMode = True Then .ShowAllData
        LastRow = .Cells(.Rows.Count, "I").End(xlUp).Row
        Set Rng = .Range("B1:I500" & LastRow).SpecialCells(12)
    End With
     
    Set wbNew = Workbooks.Add(xlWBATWorksheet)
     
    With wbNew.Worksheets(1)
        Rng.Copy
        .Range("A1").PasteSpecial xlPasteValues 'копируем значения
        .Range("A1").PasteSpecial xlPasteFormats 'копируем формат
        .Range("A1").PasteSpecial Paste:=xlPasteColumnWidths 'корпируем ширину столбцов
        Set Rng = wsSource.Range("E1:E500" & LastRow).SpecialCells(12)
        Rng.Copy Destination:=.Range("D1")
        Set Rng = wsSource.Range("G1:G500" & LastRow).SpecialCells(12)
        Rng.Copy Destination:=.Range("F1")
        .UsedRange.EntireRow.AutoFit 'выравнивание высоты строки
        .Rows(1).Font.Bold = True
        .Rows(1).WrapText = True
        .Rows(1).VerticalAlignment = xlCenter
        .Rows(1).HorizontalAlignment = xlCenter
        .Cells(1, 1).Select
        .Name = "Сравнение"
    End With
     
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Sub КопированиеДанных()
    Workbooks.Add xlWBATWorksheet
    ActiveSheet.Name = "Сравнение" 'обзываем лист новой книги
  
ThisWorkbook.ActiveSheet.Range("B1:G500").SpecialCells(12).Copy
    'ThisWorkbook.ActiveSheet.Range("B1:G500").Copy 'диапазон копирования
    'ActiveSheet.[B1].PasteSpecial
    ActiveSheet.[B1].PasteSpecial Paste:=xlPasteColumnWidths 'корпируем ширину столбцов
    ActiveSheet.[B1].PasteSpecial xlPasteValues 'копируем значения
    ActiveSheet.[B1].PasteSpecial xlPasteFormats 'копируем формат

    ActiveSheet.Rows("1:500").EntireRow.AutoFit 'выравнивание высоты строки
    End Sub