Sub test()
    myScroll 100, 10
End Sub
Sub myScroll(iRow As Long, iCol As Long)
    Dim ActiveWindow_ScrollColumn As Long
    ActiveWindow_ScrollColumn = ActiveWindow.ScrollColumn
    Cells(iRow, iCol).Select
    ActiveWindow.ScrollColumn = ActiveWindow_ScrollColumn
    ActiveWindow.ScrollRow = iRow
End Sub

Sub test()
    myScroll 50
End Sub
Sub myScroll(iRow As Long)
    Dim ActiveWindow_ScrollRow As Long
    ActiveWindow_ScrollRow = ActiveWindow.ScrollRow
    Cells(iRow, ActiveCell.Column).Select
    ActiveWindow.ScrollRow = 1
End Sub

'v2
Sub SplitSelection()
    Dim rn As Range
    On Error Resume Next
    Set rn = Intersect(Selection.Columns(1), ActiveSheet.UsedRange)
    On Error GoTo 0
    If rn Is Nothing Then Exit Sub
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim cl As Range
    For Each cl In rn
        SplitCell cl
    Next
    
    Application.Calculation = Application_Calculation
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
End Sub

Private Sub SplitCell(cl As Range)
    Dim arr As Variant
    arr = Split(cl.Value, vbLf)
    If IsArray(arr) Then
        Dim brr As Variant
        Dim bb As Variant
        For Each bb In arr
            If bb <> "" Then
                If IsEmpty(brr) Then
                    ReDim brr(0 To 0)
                Else
                    ReDim Preserve brr(0 To UBound(brr) + 1)
                End If
                brr(UBound(brr)) = bb
            End If
        Next
        If Not IsEmpty(brr) Then
            If UBound(brr) > LBound(brr) Then
                cl.Cells(2, 1).Resize(UBound(brr) - LBound(brr)).EntireRow.Insert
                cl.Cells(1, 1).Resize(UBound(brr) - LBound(brr) + 1) = Application.Transpose(arr)
            End If
        End If
    End If
End Sub

'v2
Sub SetValidation()
    SetSheetValidation Sheets("Лист1")
End Sub

Sub SetSheetValidation(sh As Worksheet)
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    InitValidation dic, Sheets("СПИСОК Поставщиков")

    Dim cl As Range
    For Each cl In sh.UsedRange.Columns(2).Cells
        SetCellValidation cl, dic
    Next
End Sub

Private Sub InitValidation(dic As Object, sh As Worksheet)
    Dim dicY As Object
    Set dicY = CreateObject("Scripting.Dictionary")
    dicY.CompareMode = 1
    
    Dim dicN As Object
    Set dicN = CreateObject("Scripting.Dictionary")
    dicN.CompareMode = 1
    Dim dicI As Object
    
    
    With sh
        Dim yy As Long
        yy = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim arr As Variant
        arr = .Cells(1, 1).Resize(yy, 2)
    End With
    For yy = 1 To UBound(arr, 1)
        If Not IsEmpty(arr(yy, 1)) Then
            If Not dicY.Exists(arr(yy, 1)) Then
                dicY.Item(arr(yy, 1)) = yy
                Set dicN.Item(arr(yy, 1)) = CreateObject("Scripting.Dictionary")
            End If
            dicN.Item(arr(yy, 1)).Item(arr(yy, 2)) = 0
        End If
    Next
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual

    Dim sValidation As String
    Dim vv As Variant
    For Each vv In dicY.Keys()
        yy = dicY.Item(vv)
        Set dicI = dicN.Item(vv)
        With sh.Cells(yy, 4).Resize(1, dicI.Count)
            .Value = dicI.Keys()
            sValidation = "='" & sh.Name & "'!" & .Address(1, 1)
        End With
        dic.Item(arr(yy, 1)) = sValidation
    Next

    Application.Calculation = Application_Calculation
    Application.ScreenUpdating = True
    Application.EnableEvents = True

End Sub

Private Sub SetCellValidation(cl As Range, dic As Object)
    With cl.Cells(1, 2).Validation
        .Delete
        If dic.Exists(cl.Value) Then
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=dic.Item(cl.Value)
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = False
            .ShowError = True
        End If
    End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Select Case Target.Address(0, 0)
    Case "B2"
        Dim arr As Variant
        arr = Range("I2:L2")
         
        Dim xx As Long
        xx = Cells(3, Columns.Count).End(xlToLeft).Column + 1
        xx = Application.Max(xx, [N1].Column)
         
        Application.EnableEvents = False
        Cells(2, xx).Value = Range("A2").Value
        Cells(3, xx).Resize(UBound(arr, 2), 1) = Application.Transpose(arr)
        Application.EnableEvents = True
    End Select
End Sub

=ИНДЕКС(Б2!B2:BG30;ПОИСКПОЗ(G35;Б2!A2:A30;1)+(ПОИСКПОЗ(H35;Б2!A2:A30;1)-ПОИСКПОЗ(G35;Б2!A2:A30;1));ПОИСКПОЗ(G34;Б2!B1:BG1;1)-(ПОИСКПОЗ(H35;Б2!A2:A30;1)-ПОИСКПОЗ(G35;Б2!A2:A30;1)))
=ИНДЕКС(Б2!B2:BG30;ПОИСКПОЗ(G35;Б2!A2:A30;1)+(ПОИСКПОЗ(I35;Б2!A2:A30;1)-ПОИСКПОЗ(G35;Б2!A2:A30;1));ПОИСКПОЗ(G34;Б2!B1:BG1;1)-(ПОИСКПОЗ(I35;Б2!A2:A30;1)-ПОИСКПОЗ(G35;Б2!A2:A30;1)))

Sub SaveTextFile()
    Const sPath = "D:\Test"

    Dim sName As String
    sName = Range("C3").Value
    
    Dim yy As Long
    yy = Application.Max(Cells(Rows.Count, [D1].Column).End(xlUp).Row, Cells(Rows.Count, [E1].Column).End(xlUp).Row, 6)
    Dim arr As Variant
    arr = Range(Cells(6, 4), Cells(yy, 5))
    Dim txt As String
    For yy = 1 To UBound(arr, 1)
        txt = txt & arr(yy, 1) & vbTab & arr(yy, 2) & vbCrLf
    Next
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(sPath) Then fso.CreateFolder sPath & "\"
    With fso.CreateTextFile(sPath & "\" & sName & ".txt", True)
        .Write txt
        .Close
    End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Select Case Target.Address(0, 0)
    Case "B2"
        Dim arr As Variant
        arr = Range("I2:L2")
        
        Dim xx As Long
        xx = Cells(3, Columns.Count).End(xlToLeft).Column + 1
        xx = Application.Max(xx, [N1].Column)
        
        Cells(3, xx).Resize(UBound(arr, 2), 1) = Application.Transpose(arr)
    End Select
End Sub

G2    =МАКС((Поставщики[Артикул]=F2)*(Поставщики[Дата]=H2)*Поставщики[Цена поставщика])
H2    =МАКС((Поставщики[Артикул]=F2)*Поставщики[Дата])

ActiveCell.FormulaR1C1 = "='[" & Workbooks(2).Name & "]Sales plan'!R34C4"

C5    =ИНДЕКС(Лист1!A:A;ОТБР((СТРОКА()-4)/28+2))

If Range("A1").Value <> "Ок" Then Exit sub

ЗАЯВКА!R11         =R10+(J11<>"")
ЗАЯВКА!S11:AB11    =ЕСЛИ(F11<>"";F11;S10)

=ПСТР(ЕСЛИ(A2="Yes";", "&A$1;"")&ЕСЛИ(B2="Yes";", "&B$1;"")&ЕСЛИ(C2="Yes";", "&C$1;"")&ЕСЛИ(D2="Yes";", "&D$1;"")&ЕСЛИ(E2="Yes";", "&E$1;"")&ЕСЛИ(F2="Yes";", "&F$1;"");3;ДЛСТР(A1&B1&C1&D1&E1&F1)+2*СЧЁТЗ($A$1:$F$1))

Range("A1:Z100").Copy
DoEvents
Application.SendKeys "^v"

Sub Макрос6()
   With Sheets("ДР").ListObjects("Таблица6")
       .Range.Rows(.Range.Rows.Count).EntireRow.Insert
   End With
End Sub

Sub Макрос6()
   With Sheets("ДР").ListObjects("Таблица6")
       .Range.Rows(.Range.Rows.Count + 1).EntireRow.Insert
       .Resize .Range.Resize(.Range.Rows.Count + 1)
       '.ListRows.Add
   End With
End Sub

.EntireRow

Sub ВыгрузкаСвод()
    Dim srr As Variant
    Dim vrr As Variant
    srr = Sheets("Свод").UsedRange
    vrr = Sheets("Выгрузка").UsedRange
    
    Dim ys As Long
    For ys = 4 To UBound(srr, 1)
        If srr(ys - 1, 1) = "название работ" Then
            If vrr(ys, 7) = "" Then
                srr(ys, 8) = vrr(ys, 1)
            ElseIf vrr(ys, 7) > 0 Then
                srr(ys, 8) = vrr(ys, 2)
            Else
                srr(ys, 8) = "-"
            End If
        End If
    Next
    
    Sheets("Свод").UsedRange = srr
End Sub

Sub Шматок()
    Dim rr As Range
    On Error Resume Next
    Set rr = Selection.SpecialCells(xlCellTypeConstants)
    On Error GoTo 0
    If rr Is Nothing Then Exit Sub
        
    Dim cl As Range
    For Each cl In rr
        JobCell cl.Value, cl.Cells(1, 2)
    Next
End Sub
Private Sub JobCell(ByVal cellIn As Variant, cellOut As Range)
    If cellIn = "" Then
        cellOut.ClearContents
    Else
        cellIn = myReplace(cellIn)
    
        Dim arr As Variant
        arr = Split(cellIn, " ")
        cellOut.Resize(1, UBound(arr) - LBound(arr) + 1) = arr
    End If
End Sub
Private Function myReplace(ByVal txt As String) As String
    Dim vv As Variant
    For Each vv In Array("/", ":")
        txt = Replace(txt, vv, " ")
    Next
    myReplace = txt
End Function

Option Explicit

Sub mySort()
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual

    Dim sh1 As Worksheet
    Set sh1 = ActiveSheet
    sh1.Copy
    Dim sh2 As Worksheet
    Set sh2 = ActiveSheet
    
    Dim yy As Long
    Dim xx As Long
    Dim arr As Variant
    With sh2
        yy = .Cells(.Rows.Count, "F").End(xlUp).Row
        arr = .Range("E1").Resize(yy, 3)
        
        For yy = 3 To UBound(arr, 1)
            Select Case arr(yy, 2)
            Case """Ф"""
                For xx = 1 To UBound(arr, 2)
                    arr(yy, xx) = Empty
                Next
            End Select
        Next
        
        .Range("E1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        
        Dim rr As Range
        Set rr = .Range("E2").Resize(UBound(arr, 1) - 1, UBound(arr, 2))
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=rr.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add Key:=rr.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange rr
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        yy = .Cells(.Rows.Count, "F").End(xlUp).Row
        .Range(.Cells(yy + 1, [E1].Column), .Cells(.Rows.Count, [G1].Column)).Clear
        arr = .Range("E1").Resize(yy, 3)
        
        Dim uu As Long
        For yy = UBound(arr, 1) To 3 Step -1
            uu = WorksheetFunction.Match(arr(yy, 1), sh1.Columns("E:E"), 0)
            .Rows(yy + 1).Insert
            sh1.Cells(uu + 1, 5).Resize(1, 3).Copy .Cells(yy + 1, 5)
        Next
    End With
    
    Application.Calculation = Application_Calculation
End Sub

=ВПР(;;;1)

     Intersect(Rows(.Row + .Rows.Count), .EntireColumn).Insert , CopyOrigin:=xlFormatFromLeftOrAbove

=ПОИСКПОЗ(C4;Лист1!B:B;0)