Страницы: 1
RSS
Формирование списка на основе нескольких переменных
 
Добрый день, есть задачка по автоматизации формирования списка данных. На склад в течение двух лет поступали материалы от поставщика. Каждое поступление материалов оформлялось приходной накладной с указанием номера, даты накладной, артикула и количества поступивших материалов. Часть из поступивших материалов были проданы. Необходимо для оставшихся материалов подобрать номера накладных, по которым они приходили. При этом считается, что при продаже материалов в первую очередь со склада уходили товары, которые были куплены по более ранним накладным (принцип First In, First Out). Подскажите, пожалуйста, в какую сторону проще подумать над решением.
 
См. файл

КОД
Изменено: New - 20.04.2021 17:06:50
 
И ещё вариант.
Код
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
 
Сработало. Спасибо за решения!
Страницы: 1
Наверх