Sub Main()
Dim dicOst As Object
Set dicOst = GetOst()
Dim dicPri As Object
Set dicPri = GetPri()
PriMinusOst dicPri, dicOst
Dim arr As Variant
arr = DicToArr(dicPri)
OutArr arr, Workbooks.Add(1).Sheets(1).Cells(1, 1)
End Sub
Sub OutArr(arr As Variant, cl As Range)
With cl.Resize(UBound(arr, 1), UBound(arr, 2))
.Cells = arr
.Columns("A:B").AutoFit
End With
cl.Parent.Parent.Saved = True
End Sub
Function DicToArr(dic As Object) As Variant
Dim v As Variant
Dim y As Long
y = 1 'Заголовок
For Each v In dic.Items
y = y + v.Count
Next
Dim arr As Variant
ReDim arr(1 To y, 1 To 3)
y = 1
arr(y, 1) = "Артикул материала"
arr(y, 2) = "№ накладной"
arr(y, 3) = "Кол-во остаток по накладной"
Dim w As Variant
For Each v In dic.Keys
For Each w In dic.Item(v).Keys
y = y + 1
arr(y, 1) = v
arr(y, 2) = w
arr(y, 3) = dic.Item(v).Item(w)
Next
Next
DicToArr = arr
End Function
Sub PriMinusOst(dicPri As Object, dicOst As Object)
Dim vArt As Variant
Dim ost As Long
Dim i As Long
Dim d As Long
Dim arr As Variant
Dim dic As Object
For Each vArt In dicOst.Keys
If dicPri.Exists(vArt) Then
Set dic = dicPri.Item(vArt)
ost = dicOst.Item(vArt)
arr = dic.Items()
For i = UBound(arr) To 0 Step -1
d = IIf(ost < arr(i), ost, arr(i))
arr(i) = arr(i) - d
ost = ost - d
If arr(i) = 0 Then
dic.Remove dic.Keys()(i)
Else
dic.Item(dic.Keys()(i)) = arr(i)
End If
If ost <= 0 Then Exit For
Next
Set dicPri.Item(vArt) = dic
End If
Next
End Sub
Function GetPri() As Object
Dim sh As Worksheet
Set sh = Worksheets("Дано - приходы")
With sh
Dim y As Long
Dim arr As Variant
y = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range(.Cells(1, 1), .Cells(y, 4))
End With
Dim s1 As String
Dim s2 As String
Dim s3 As String
Set sh = Workbooks.Add(1).Sheets(1)
With sh
With .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
.Cells = arr
s1 = .Columns(2).Address(0, 0)
s2 = .Columns(1).Address(0, 0)
s3 = .Address(0, 0)
With .Parent.Sort
.SortFields.Clear
.SortFields.Add Key:=Range(s1), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range(s2), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.SetRange Range(s3)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
arr = .Cells
End With
End With
sh.Parent.Close False
Set sh = Nothing
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
For y = 2 To UBound(arr, 1)
If Not dic.Exists(arr(y, 3)) Then Set dic.Item(arr(y, 3)) = CreateObject("Scripting.Dictionary")
dic.Item(arr(y, 3)).Item(arr(y, 1)) = arr(y, 4)
Next
Set GetPri = dic
End Function
Function GetOst() As Object
Dim sh As Worksheet
Set sh = Worksheets("Дано - остатки")
With sh
Dim y As Long
Dim arr As Variant
y = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range(.Cells(1, 1), .Cells(y, 2))
End With
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
For y = 2 To UBound(arr, 1)
dic.Item(arr(y, 1)) = dic.Item(arr(y, 1)) + arr(y, 2)
Next
Set GetOst = dic
End Function
|