=(ABS(СЛЧИС()*(J2-F2)+F2),

=ОКРУГЛ(ABS(СЛЧИС()*(J2-F2)+F2);2)

Sub MakeFolders()
Dim Rng As Range
Dim maxRows, maxCols, r, c As Integer
Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count
For c = 1 To maxCols
r = 1
Do While r <= maxRows
If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
On Error Resume Next
End If
r = r + 1
Loop
Next c
End Sub

Sub перенос()
Dim i As Long, j As Integer, ws As Worksheet, aws As Worksheet, x As Range
    Set x = Rows(1).Find("исследование", , , xlWhole)
    If x Is Nothing Then Exit Sub Else j = x.Column
    Application.ScreenUpdating = False: Set aws = Sheets("реестр")
    For i = aws.Cells(Rows.Count, j).End(xlUp).Row To 2 Step -1
        If aws.Cells(i, j) <> "" Then
            On Error Resume Next: Set ws = ThisWorkbook.Sheets(CStr(aws.Cells(i, j)))
            If Err <> 0 Then
                Set ws = Sheets.Add: ActiveSheet.Name = aws.Cells(i, j): On Error GoTo 0
                aws.Cells.Copy
                ws.Cells.PasteSpecial Paste:=xlPasteColumnWidths
                ws.Cells.PasteSpecial Paste:=xlPasteFormats
            End If
            W = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1 'номер строки куда вставлять
            aws.Range("A" & i & ":V" & i).Copy ws.Cells(W, 1)
            aws.Range("Y" & i & ":W" & i).Copy ws.Cells(W, "Y")
    End If: Next
End Sub