Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Подсчет остатка по ФИФО
 
#1
01.12.2021 17:05:23
Друзья, всех приветствую.

Очень нужен макрос для подсчета остатка по методу ФИФО. Искал разные варианты на форумах, но ничего подходящего для себя не нашел (либо плохо искал).
Поэтому обращаюсь к Вам за помощью.

Имеем покупки ЦБ в разные даты и по разным ценам. Есть готовый файл с остатками, с которым можно сверяться и подбивать свой файл (В примере эту роль выполняет столбец "Актуальный остаток").
Если ЦБ докупаются, то покупки просто ниже вставляются в таблицу покупок. При продаже ЦБ необходимо вычесть кол-во продажи из старых покупок. Необходимо чтобы макрос вычетал из покупки необходимую разницу (столбец D) , либо удалял строку и переходил на следующую покупку, также удаляя ее, либо вычетая необходимое кол-во чтобы выровнять покупное кол-во ЦБ с актуальным остатком.

Очень надеюсь на Ваше содействие в данном вопросе.
 
 
 
#2
01.12.2021 17:27:41
Код
Option Explicit

Sub FIFO()
    Dim tb1 As ListObject
    Set tb1 = Sheets("Покупки").ListObjects("Таблица1")
            
    Dim ar1 As Variant
    ar1 = tb1.DataBodyRange
    
    Dim arO As Variant
    With Sheets("остаток ЦБ")
        arO = .Range(.Cells(1, 3), .Cells(.Rows.Count, 5).End(xlUp))
    End With
    
    Dim yO As Long
    Dim y1 As Long
    Dim d As Double
    For yO = 2 To UBound(arO, 1)
        For y1 = 1 To UBound(ar1, 1)
            If arO(yO, 3) = ar1(y1, 2) Then
                d = IIf(arO(yO, 1) < ar1(y1, 3), arO(yO, 1), ar1(y1, 3))
                If d = 0 Then
                    Exit For
                Else
                    arO(yO, 1) = arO(yO, 1) - d
                    ar1(y1, 3) = ar1(y1, 3) - d
                End If
            End If
        Next
    Next
    tb1.DataBodyRange = ar1
End Sub
 
 
 
#3
01.12.2021 18:22:15
кнопка цитирования не для создания бездумных копий [МОДЕРАТОР]

Попробовал запустить макрос, но он подбивает остаток на разницу между актуальным количеством и текущим.
Например, кол-во в покупках 200 000 штук, текущий остаток 180 000 штук. Разница 20 000.
Необходимо, чтобы в покупках выходила сумма на 180 000. Сейчас макрос высчитывает на остакок в 20 000 штук.
Изменено: vikttur - 01.12.2021 18:27:20
 
 
 
#4
02.12.2021 09:18:41
Код
Option Explicit

Sub FIFO()
    FLIFO True
End Sub

Sub LIFO()
    FLIFO False
End Sub

Sub FLIFO(upDown As Boolean)
    Dim tb1 As ListObject
    Set tb1 = Sheets("Покупки").ListObjects("Таблица1")
            
    Dim ar1 As Variant
    ar1 = tb1.DataBodyRange
    
    Dim arO As Variant
    With Sheets("остаток ЦБ")
        arO = .Range(.Cells(1, 3), .Cells(.Rows.Count, 5).End(xlUp))
    End With
    
    Dim yMin As Long
    If upDown Then
        yMin = 1
    Else
        yMin = UBound(ar1, 1)
    End If
    
    Dim yO As Long
    Dim y1 As Long
    Dim d As Double
    For yO = 2 To UBound(arO, 1)
        For y1 = yMin To UBound(ar1, 1) - yMin + 1 Step 1 + 2 * (UBound(ar1, 1) = yMin)
            If arO(yO, 3) = ar1(y1, 2) Then
                d = IIf(arO(yO, 1) < ar1(y1, 3), arO(yO, 1), ar1(y1, 3))
                If d <> 0 Then
                    arO(yO, 1) = arO(yO, 1) - d
                End If
                ar1(y1, 3) = d
            End If
        Next
    Next
    tb1.DataBodyRange = ar1
End Sub
Изменено: МатросНаЗебре - 02.12.2021 09:57:36
 
 
 
#5
02.12.2021 11:43:27
Может так надо
Код
Sub SENasd()
Dim Col1 As New Collection, Rg1 As Range, Tp1, Tp2, Dic1, Arr1, i&, j&, Flak As Boolean
Set Dic1 = CreateObject("scripting.dictionary")
Arr1 = Sheets("остаток ЦБ").Cells(3).CurrentRegion: ReDim Tp1(2)
    For i = 2 To UBound(Arr1)
Tp1(0) = True: Tp1(1) = Arr1(i, 1): Tp1(2) = 0: Dic1(Arr1(i, 3)) = Tp1
    Next
    
    Set Rg1 = Sheets("Покупки").Cells(1).CurrentRegion: Arr1 = Rg1.Value
For i = UBound(Arr1) To 2 Step -1: ReDim Tp2(1 To UBound(Arr1, 2)): For j = 1 To UBound(Arr1, 2)
Tp2(j) = Arr1(i, j): Next
    If Dic1(Arr1(i, 2))(1) < Dic1(Arr1(i, 2))(2) + Arr1(i, 3) Then
If Dic1(Arr1(i, 2))(2) = 0 Then Tp2(3) = Dic1(Arr1(i, 2))(1) Else _
Tp2(3) = Dic1(Arr1(i, 2))(1) - Dic1(Arr1(i, 2))(2): Flak = True
    Else: Tp1 = Dic1(Arr1(i, 2)): Tp1(2) = Tp1(2) + Arr1(i, 3): Dic1(Arr1(i, 2)) = Tp1
    End If
If Dic1(Arr1(i, 2))(0) Then Col1.Add Tp2
If Flak Then Tp1 = Dic1(Arr1(i, 2)): Tp1(0) = False: Dic1(Arr1(i, 2)) = Tp1: Flak = False
Next

ReDim Arr1(1 To Col1.Count, 1 To UBound(Tp2)): i = Col1.Count
For Each Tp1 In Col1: For j = 1 To UBound(Tp2)
Arr1(i, j) = Tp1(j)
Next: i = i - 1: Next
Rg1.Cells(2, 1).Resize(UBound(Arr1), UBound(Arr1, 2)) = Arr1
Set Rg1 = Range(Rg1.Rows(UBound(Arr1) + 2), Rows(Rg1.CurrentRegion.Rows.Count))
Rg1.Clear
End Sub
 
 
 
#6
04.12.2021 17:39:36
Всем огромное спасибо!! Оба варианта рабочие.

, У Вас LIFO и FIFO наоборот высчитываются) При использовании макроса FIFO, вычитаются из свежих покупок, но должно быть наоборот.
 
 
 
Страницы: 1
Наверх