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
|