Option Explicit

Sub РаспределитьПоСкладам()
    'Версия 2.
    Dim sh1 As Worksheet
    Set sh1 = ActiveSheet
    Dim y As Long
    Dim rn1 As Range
    With sh1
        y = .Cells(.Rows.Count, 2).End(xlUp).Row
        
        Dim arS As Variant
        y = .Cells(.Rows.Count, 8).End(xlUp).Row
        arS = .Cells(1, 8).Resize(y, 8)
        .Cells(1, 9).Resize(y, 1).FormulaR1C1 = "=SUMIFS(C3,C4,C8)"
        
        y = .Cells(.Rows.Count, 2).End(xlUp).Row
        If y = 1 Then Exit Sub
        Dim ar1 As Variant
        
        Set rn1 = .Cells(2, 1).Resize(y - 1, 4)
        ar1 = rn1
        
    End With
    
    Dim wb2 As Workbook
    Set wb2 = Workbooks.Add(1)
    Dim sh2 As Worksheet
    Set sh2 = wb2.Worksheets(1)
    Dim rn2 As Range
    Set rn2 = sh2.Cells(1, 1).Resize(UBound(ar1, 1), UBound(ar1, 2))
    
    rn2 = ar1
    rn2.Columns(4).Clear
    
    With sh2.Sort
        .SortFields.Clear
        .SortFields.Add Key:=rn2.Columns(3), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .SetRange rn2
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    With sh2
        .Range("F1").Resize(UBound(arS, 1)).FormulaR1C1 = "=SUMIFS(C3,C4,C[2])"
        .Range("G1").Resize(UBound(arS, 1)).FormulaR1C1 = "=RC[-1]=MIN(C[-1])"
        .Range("H1").Resize(UBound(arS, 1)).FormulaR1C1 = arS
        .Range("I1").FormulaR1C1 = "=VLOOKUP(TRUE,C[-2]:C[-1],2,0)"
    End With
    
    For y = 1 To rn2.Rows.Count
        If rn2.Cells(y, 1).Value <> "" Then
            rn2.Cells(y, 4).Value = sh2.Cells(1, 9).Value
            sh2.UsedRange.Calculate
        End If
    Next
    
    Dim ar2 As Variant
    ar2 = rn2
    wb2.Close False
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For y = 1 To UBound(ar2, 1)
        dic.Item(ar2(y, 2)) = ar2(y, 4)
    Next
    For y = 1 To UBound(ar1, 1)
        ar1(y, 4) = dic.Item(ar1(y, 2))
    Next
    rn1 = ar1

End Sub

Option Explicit

Sub РаспределитьПоСкладам()
    'Версия 3.
    Dim sh1 As Worksheet
    Set sh1 = ActiveSheet
    Dim y As Long
    Dim rn1 As Range
    With sh1
        y = .Cells(.Rows.Count, 2).End(xlUp).Row
         
        Dim arS As Variant
        y = .Cells(.Rows.Count, 8).End(xlUp).Row
'        arS = .Cells(1, 8).Resize(y, 8)
'        .Cells(1, 9).Resize(y, 1).FormulaR1C1 = "=SUMIFS(C3,C4,C8)"
        With .Range("AF4:AF6")
            arS = .Columns(1)
            .Columns(2).FormulaR1C1 = "=SUMIFS(C20,C32,C32)"
        End With
         
        y = .Cells(.Rows.Count, 6).End(xlUp).Row
        If y = 1 Then Exit Sub
        Dim ar1 As Variant
        Dim ar4 As Variant
        Dim ar3 As Variant
         
        Set rn1 = .Range(.Cells(12, 32), .Cells(y, 32))
        ar1 = .Range(.Cells(12, 6), .Cells(y, 6))
        ar4 = .Range(.Cells(12, 7), .Cells(y, 7))
        ar3 = .Range(.Cells(12, 20), .Cells(y, 20))
         
    End With
     
    Dim wb2 As Workbook
    Set wb2 = Workbooks.Add(1)
    Dim sh2 As Worksheet
    Set sh2 = wb2.Worksheets(1)
    Dim rn2 As Range
    Set rn2 = sh2.Cells(1, 1).Resize(UBound(ar1, 1), 4) 'UBound(ar1, 2))
     
    rn2.Columns(2) = ar1
    rn2.Columns(1) = ar4
    rn2.Columns(3) = ar3
    rn2.Columns(4).Clear    '?
     
    With sh2.Sort
        .SortFields.Clear
        .SortFields.Add Key:=rn2.Columns(3), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .SetRange rn2
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
     
    With sh2
        .Range("F1").Resize(UBound(arS, 1)).FormulaR1C1 = "=SUMIFS(C3,C4,C[2])"
        .Range("G1").Resize(UBound(arS, 1)).FormulaR1C1 = "=RC[-1]=MIN(C[-1])"
        .Range("H1").Resize(UBound(arS, 1)).FormulaR1C1 = arS
        .Range("I1").FormulaR1C1 = "=VLOOKUP(TRUE,C[-2]:C[-1],2,0)"
    End With
     
    For y = 1 To rn2.Rows.Count
        If rn2.Cells(y, 1).Value = "M" Then
            rn2.Cells(y, 4).Value = sh2.Cells(1, 9).Value
            sh2.UsedRange.Calculate
        End If
    Next
     
    Dim ar2 As Variant
    ar2 = rn2.Columns(4)
    Dim ar5 As Variant
    ar5 = rn2.Columns(2)
    Dim ar6 As Variant
    ReDim ar6(1 To UBound(ar1, 1), 1 To 1)
    
    wb2.Close False
     
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For y = 1 To UBound(ar2, 1)
        dic.Item(ar5(y, 1)) = ar2(y, 1)
    Next
    For y = 1 To UBound(ar1, 1)
        ar6(y, 1) = dic.Item(ar1(y, 1))
    Next
    rn1 = ar6
 
End Sub