Sub test()
    Dim LastRow As Long
    Dim mySheet As Worksheet

    Set mySheet = ActiveSheet
    Application.ScreenUpdating = False
    With mySheet
          LastRow = .Cells(.Rows.Count, 4).End(xlUp).Row
         With .Range("AF1:AF" & LastRow)
            .HorizontalAlignment = xlCenter
            .NumberFormat = "General"
            .FormulaLocal = "=ЕСЛИ(ИЛИ(И(P1=0;T1=0;U1=0);И(ЕСЛИ(P1>=ЕСЛИ(T1<50;U1+10;U1/14*21);0;ЕСЛИ(T1<50;U1+10;U1/14*21)-P1)<5;ЕСЛИ(P1>=ЕСЛИ(T1<50;U1+10;U1/14*21);0;ЕСЛИ(T1<50;U1+10;U1/14*21)-P1)>0;T1>2;P1<U1*2));ОКРУГЛ(ЕСЛИ(P1>=ЕСЛИ(T1<50;U1+10;U1/14*21);0;ЕСЛИ(T1<50;U1+10;U1/14*21)-P1);-1)+10;ОКРУГЛ(ЕСЛИ(P1>=ЕСЛИ(T1<50;U1+10;U1/14*21);0;ЕСЛИ(T1<50;U1+10;U1/14*21)-P1);-1))"
            .Calculate
            .NumberFormat = "@"
            '.Value = .Value
        End With
         Range("AF1:AF2").ClearContents
         mySheet.Range("AD2").Copy mySheet.Range("AF2")
    End With
    
    Application.ScreenUpdating = True
    
    If MsgBox("Перенести значения в колонку заказ?", vbQuestion + vbYesNo, "Перенос") = vbNo Then Exit Sub

    Range("AD:AD") = Range("AF:AF").Value
 
    
End Sub

Sub Престиж()

    Dim mySheet As Worksheet
    Dim myBook As Workbook
    Dim OpenFile As Variant
    Dim wbSource As Workbook
    Dim wsSourceSheetName As String
    Dim LastRow
    Dim A As Range
   
    
    Set myBook = ActiveWorkbook
    OpenFile = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", 1, "Выберите файл с престижными позициями", , False)
                    If VarType(OpenFile) = vbBoolean Then 'преждевременная остановка макроса
                Exit Sub
                    End If
    Application.ScreenUpdating = False
    
    Set wbSource = Workbooks.Open(OpenFile, UpdateLinks:=False, ReadOnly:=True)
    wsSourceSheetName = wbSource.ActiveSheet.Name
    sFilename = Mid$(OpenFile, InStrRev(OpenFile, Application.PathSeparator, -1, vbBinaryCompare) + 1)
    
 
         For Each A In wbSource.Worksheets(1).[A1].CurrentRegion.Columns(1).Cells
        i = 1
        A = A.Resize(1, 2)
            If A.Row >= 2 Then
        With myBook
                    With .Worksheets(1)
                        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                            .Cells(LastRow, 4) = A(i, 2)
                    End With

        End With
            End If
        Next

    

End Sub

Sub Листы()
Dim Sh
For Each Sh In ActiveWorkbook.Worksheets
        Sh.Cells(1, 2) = "123"
        Sh.Cells(1, 4) = "321"
        Cells (4, 1).Select
        Next Sh

End Sub

Sub Кратности1()
Dim LastRow&, OpenFile
OpenFile = Application.GetOpenFilename _
                ("Excel files(*.xls*),*.xls*", 1, "Выберите файл с кратностями", , False)
                    If VarType(OpenFile) = vbBoolean Then 'преждевременная остановка макроса
                Exit Sub
                    End If
Application.ScreenUpdating = False
    Cells(2, 4) = "Кратности"
     Range("D2").VerticalAlignment = xlCenter
     Range("D2").Font.Bold = True
    Columns("D:D").Select
    With Selection.Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent4
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
Cells(3, 4).FormulaLocal = "=ВПР(B3;[Кратности1.xlsx]Лист2!$A$2:$B$1000;2;0)"
LastRow = Cells(Rows.Count, 4).End(xlUp).Row + 1
Range("D200900:D" & LastRow).FormulaR1C1 = Range("D3").FormulaR1C1
Application.ScreenUpdating = True
End Sub

    Dim A, B, i%, Sample, LastRow&, DeskTopPath$
    Dim Cl As Range
    Set B = ActiveWorkbook
    Workbooks.Add
    Set Sample = Workbooks(Workbooks.Count)
    For Each Cl In B.Worksheets(1).[A11].CurrentRegion.Columns(1).Cells
        i = 1
        A = Cl.Resize(1, 31)
            If Cl.Row >= 12 Then
                If Not Cl.EntireRow.Hidden Then
        With Sample
            With .Worksheets("Лист1")
                        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                        If IsEmpty(.[A1]) Then LastRow = 1
                            .Cells(LastRow, 1) = A(i, 3)
                            .Cells(LastRow, 2) = A(i, 5)
                            .Cells(LastRow, 3) = A(i, 31)
            End With
        End With
                End If
            End If
    Next

End Sub

A = Workbooks("start.xlsx").Worksheets(1).[A1].CurrentRegion

Sub Test()
    Dim A, Sh, i%, LastRow&
    A = Workbooks("start.xlsx").Worksheets(1).[A1].CurrentRegion
    For Each Sh In Workbooks("finish.xlsx").Worksheets
    Next Sh
    For i = 3 To UBound(A)
        A(i, 1) = Format$(0, A(i, 1))
        With Workbooks("finish.xlsx")
                If Not SheetExists(A(i, 1), Workbooks("finish.xlsx")) Then
                    With .Worksheets.Add(After:=.Worksheets(.Worksheets.Count)): .Name = A(i, 1):
                    End With
                End If
                With .Worksheets(A(i, 1))
                LastRow = .Cells(.Rows.Count, 1).SpecialCells(xlCellTypeVisible).End(xlUp).Row + 1                
                If IsEmpty(.[A1]) Then LastRow = 1
                        .Cells(LastRow, 1) = A(i, 2)
                        .Cells(LastRow, 2) = A(i, 3)
                        .Cells(LastRow, 3) = A(i, 4)
            End With
        End With
    Next i
  
End Sub
Function SheetExists(SheetName, Optional wb As Workbook) As Boolean
    If wb Is Nothing Then Set wb = ActiveWorkbook
    On Local Error Resume Next: SheetExists = wb.Worksheets(SheetName).Name = SheetName: Err.Clear
End Function

Sub Magic()
    Dim A, Sh, i%, LastRow&, OpenFile
    A = ThisWorkbook.Worksheets(1).[A1].CurrentRegion
    'диалоговое окно для выбора файла'
    OpenFile = Application.GetOpenFilename _
                ("Excel files(*.xls*),*.xls*", 1, "Выбрать шаблон для заполнения", , False)
                    If VarType(OpenFile) = vbBoolean Then
        Exit Sub
         End If
         Workbooks.Open OpenFile
    For Each Sh In Workbooks(Workbooks.Count).Worksheets
    Next Sh
    For i = 1 To UBound(A)
        A(i, 1) = Format$(0, A(i, 1)) 'формат листа'
        With Workbooks(Workbooks.Count)
                With .Worksheets(A(i, 1))
                LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                If IsEmpty(.[A1]) Then LastRow = 1
                .Cells(LastRow, 1) = A(i, 2)
                .Cells(LastRow, 2) = A(i, 3)
                .Cells(LastRow, 3) = A(i, 4)
                End With
        End With
    Next i
End Sub
Function SheetExists(SheetName, Optional wb As Workbook) As Boolean
    If wb Is Nothing Then Set wb = ActiveWorkbook
    On Local Error Resume Next: SheetExists = wb.Worksheets(SheetName).Name = SheetName: Err.Clear
End Function