Страницы: 1 2 След.
RSS
Автоматизация перемещения единицы товара на магазины с нулевым остатком и продажами более нуля
 
Необходимо сделать переброску тест систем из ячеек где есть свободные туда где их не хватает.
в приложенном файле все отобразил. Пытался написать с помощью Если, но тут определено нужен макрос.

Тест забирается из ячейки хранения где есть остаток, но нет Исползованных или Остаток больше чем Использованных, в ближайшую ячейку где были использованные, но нет остатка
Изменено: vikttur - 11.10.2021 22:37:26
 
Скрытый текст

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
JayBhagavan,  :D  
Не бойтесь совершенства. Вам его не достичь.
 
JayBhagavan, )))
постараюсь перевести я на более простой язык. Например что красные столбцы это остатки скажем на магазине, а синие это продажи. Нужен такой макрос который смотрит по строке. И из магазинов где товара на остатках больше чем продается перебрасывает товар туда где он продался и на остатках 0.   При этом перебрасывается только одна  штука. Только магазинов при этом ну скажем 40. В файле я стрелками логику вроде попытался объяснить. Но что то пошло не так.
 
DrDreik А, Ваше объяснение порождает вопросы, а не проливает свет истины:
1) на 1м листе верхнюю таблицу макрос меняет? Или макрос формирует что куда переместить (таб. на листе 2)?
2) Почему по одной штуке, например, если на остатке 1 а продано 10, то надо переместить 9?
3) Макрос делает один проход по товару/тесту или пока по единичке все неудовлетворённые потребности в магазинах/ячейках не закроет?
Так, наблюдение. На первом листе у Вас тесты и ячейки, а на втором товар и магазины...

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
Цитата
DrDreik А написал:
Переброска тест систем по ячейкам
а диффузию конгломерации учитывать?
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Добрый день.
Цитата
JayBhagavan написал:
Ваше объяснение порождает вопросы, а не проливает свет истины:
Прошу извинить за косноязычность.
Цитата
JayBhagavan написал:
1) на 1м листе верхнюю таблицу макрос меняет?
Не принципиально, главное чтобы сформировал список на втором листе что куда переместить
Цитата
JayBhagavan написал:
2) Почему по одной штуке, например, если на остатке 1 а продано 10, то надо переместить 9?
Тут имеем дело с тест системами и достаточно 1 единицы чтобы закрыть потребность ячейки(магазина)
Цитата
JayBhagavan написал:
3) Макрос делает один проход по товару/тесту или пока по единичке все неудовлетворённые потребности в магазинах/ячейках не закроет?
пока не наведет порядок по строке. т.е все где были продажи(использованы) не пополнятся
Цитата
JayBhagavan написал:
Так, наблюдение. На первом листе у Вас тесты и ячейки, а на втором товар и магазины...
Спасибо за внимательность. просто думал это представить как продажи товара чтобы было проще. прикрепил исправленный файл. Можно считать, что это товар и магазины с продажами остатками, только их 40 и товар перемещается по одному.    
 
Цитата
DrDreik А написал: Спасибо за внимательность
пока вас носом не ткнули - вы самостоятельно задуматься о сути проблемы не могли? (или не хотели?) - вот вам задача, решайте, как хотите) так?
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Нет, вы знаете, это не так. Для меня действительно важно решить эту задачу, т.к. я большой противник ручного труда там, где есть возможность использовать алгоритм. Ексель с этой точки зрения очень классный инструмент, но моих знаний отнюдь недостаточно для решения этой конкретной задачи, а бюджет на программиста к сожалению мне никто не подпишет. Там где я могу справиться я делаю это самостоятельно. Да и работа моя далека от программирования, если вот так честно. Я считаю, что если есть пробел или недопонимание всегда можно задать вопрос как это сделал уважаемый JayBhagavan, на все вопросы я готов ответить. Я еще раз прошу прощения если чем-то вас задел или обидел, я не ставил это своей целью.
 
Цитата
DrDreik А написал:
Я еще раз прошу прощения если чем-то вас задел или обидел,
ровным счетом никого и не задали и не обидели (не возможно не задеть, ни обидеть человека, который не собирается быть задетым или обиженным)
удивляет ваше отношение к собственной задаче
вам интересно получить ответ? так нужно упираться изо всех сил чтобы хоть кто-то понял что вы решаете!
пока задача понятна только вам - решать вам ее самостоятельно)))
удачи!
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Цитата
DrDreik А написал: Прошу извинить за косноязычность.
Ни в чём Вас не обвинял - констатировал факт, что с таким объясненим программу не написать. Расслабьтесь. :)
Цитата
DrDreik А написал: Не принципиально, главное чтобы сформировал список на втором листе что куда переместить
1) Для написания программы - принципиально. Допустим, пользователь нажал кнопку, макрос выполнился, заполнил таблицу на листе 2 (пока не забыл, эту таблицу дополнять новыми записями или перезаписывать её каждый раз?). Потом нажал ещё раз кнопку, а исходная таблица та же и что должно произойти?
Цитата
DrDreik А написал: Тут имеем дело с тест системами и достаточно 1 единицы чтобы закрыть потребность ячейки(магазина)
2) В общем берём за данность, что при неудовлетворённой потребности по тесту/товару всегда дополняем остаток на единицу, если имеются свободные остатки в других ячейках/магазинах.
Цитата
DrDreik А написал: пока не наведет порядок по строке. т.е все где были продажи(использованы) не пополнятся
3) Как я понял, кому не хватало дали по единичке и успокоились, то есть - один проход по строке.

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
Цитата
JayBhagavan написал:
1) Для написания программы - принципиально. Допустим, пользователь нажал кнопку, макрос выполнился, заполнил таблицу на листе 2 (пока не забыл, эту таблицу дополнять новыми записями или перезаписывать её каждый раз?). Потом нажал ещё раз кнопку, а исходная таблица та же и что должно произойти?
Очень интересное замечание, тогда получается нужно менять исходную таблицу, а список дополнять. Чтобы исключить человеческий фактор.
Цитата
JayBhagavan написал:
2) В общем берём за данность, что при неудовлетворённой потребности по тесту/товару всегда дополняем остаток на единицу, если имеются свободные остатки в других ячейках/магазинах.
Да, все верно там где есть продажа/использование остаток в итоге должен быть 1
 
Цитата
DrDreik А написал: там где есть продажа/использование остаток в итоге должен быть 1
Расшифруйте новую вводную. На примере желательно.

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
Цитата
JayBhagavan написал:
Расшифруйте новую вводную. На примере желательно.
Это не новая вводная это стрелками показано, там где было использование там остаток одна штука.
Цитата
JayBhagavan написал:
Как я понял, кому не хватало дали по единичке
вот именно это. Спасибо.
 
DrDreik А, ниже формулировка задачи так, как я её понял:
в таблице (Лист1, строка = товар, столбцы = остатки и продажи по магазинам) если остаток товара в магазине мене продаж, то ищем магазин (с лева на право) с наибольшим свободным остатком (остаток минус продажа) и перемещаем одну единицу товара на остаток магазина, где остаток меньше продаж. Каждое перемещение фиксируем в отдельной таблице (Лист2) со следующими полями: код товара, название, откуда, куда, сколько (ВСЕГДА ОДНА ШТУКА). Таблица дополняется сверху вниз.
Верно ли я понял и сформулировал Вашу задачу?
Изменено: JayBhagavan - 10.10.2021 17:39:19

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
Цитата
и перемещаем одну единицу товара на остаток магазина, где остаток меньше продаж.
Если мы берём такую формулировку, то сравнивается остаток и продажа. И появляется потребность в перемещении если остаток не ноль, а продажи больше остатка.
Например: Пусть Остаток 2 продажа 5. По такой логике уже уже необходимо перемещение.
Цитата
DrDreik А написал: если остаток товара в магазине, где есть продажа, равен нулю, то ищем магазин.....
Нам же необходимо взять магазин в котором неважно сколько было бы продаж, главное чтобы они были. А остаток при этом именно ноль. И сделать остаток 1 шт.

Получается так:
в таблице (Лист1, строка = товар, столбцы = остатки и продажи по магазинам) если остаток товара в магазине равен нулю и при этом в нем была продажа (продажа больше 0), то ищем магазин (с лева на право) с наибольшим свободным остатком (остаток минус продажа) и перемещаем одну единицу товара на остаток магазина, где была продажа а остаток при этом 0. Каждое перемещение фиксируем в отдельной таблице (Лист2) со следующими полями: код товара, название, откуда, куда, сколько (ВСЕГДА ОДНА ШТУКА). Таблица дополняется сверху вниз.
 
Код
Option Explicit

Sub Переброска()
    Dim arr As Variant
    arr = GetArr(ActiveSheet)
    Dim orr As Variant
    orr = GetOutArr(arr)
    OutArr orr
End Sub

Sub OutArr(arr As Variant)
    If Not IsEmpty(arr) Then
        With Workbooks.Add(1).Sheets(1).Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
            .Columns(1).NumberFormat = "@"
            .Columns(1).AutoFit
            .Cells = arr
            .Columns(1).AutoFit
        End With
    End If
End Sub

Function GetOutArr(arr As Variant) As Variant
    Dim y As Long
    Dim x As Integer
    Dim k As Integer
    Dim crr As Variant
    crr = arr
    Dim brr As Variant
    Dim b As Long
    Dim i As Byte
    For i = 0 To 1
        For y = 5 To UBound(arr, 1)
            For x = 3 To UBound(arr, 2) - 1 Step 2
                If arr(y, x) > arr(y, x + 1) Then
                    For k = x - 2 To 3 Step -2
                        If arr(y, x) > arr(y, x + 1) Then
                            If arr(y, k) < arr(y, k + 1) Then
                                arr(y, x) = arr(y, x) - 1
                                arr(y, k) = arr(y, k) + 1
                                
                                b = b + 1
                                If i = 0 Then
                                Else
                                    brr(b, 1) = arr(y, 1)
                                    brr(b, 2) = arr(y, 2)
                                    brr(b, 3) = arr(2, x)
                                    brr(b, 4) = arr(2, k)
                                    brr(b, 5) = 1
                                End If
                            End If
                        Else
                            Exit For
                        End If
                    Next
                    For k = x + 2 To UBound(arr, 2) - 1 Step 2
                        If arr(y, x) > arr(y, x + 1) Then
                            If arr(y, k) < arr(y, k + 1) Then
                                arr(y, x) = arr(y, x) - 1
                                arr(y, k) = arr(y, k) + 1
                            
                                b = b + 1
                                If i = 0 Then
                                Else
                                    brr(b, 1) = arr(y, 1)
                                    brr(b, 2) = arr(y, 2)
                                    brr(b, 3) = arr(2, x)
                                    brr(b, 4) = arr(2, k)
                                    brr(b, 5) = 1
                                End If
                            End If
                        Else
                            Exit For
                        End If
                    Next
                End If
            Next
        Next
        If i = 0 Then
            If b = 0 Then
                Exit For
            Else
                ReDim brr(1 To b, 1 To 5)
                b = 0
                arr = crr
            End If
        End If
    Next i
    GetOutArr = brr
End Function

Function GetArr(sh As Worksheet) As Variant
    With sh
        Dim y As Long
        Dim x As Integer
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        x = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
        GetArr = .Range(.Cells(1, 1), .Cells(y, x))
    End With
End Function
 
Огромное спасибо! Очень круто! Можно только небольшие поправки
1. Чтобы товар забирался с магазина  с наибольшим свободным остатком
2. И если на остатках изначально есть товар туда ничего не перемещалось

В прикреплённом файле, на втором листе я скопировал результат и добавил комментарии.
Изменено: vikttur - 11.10.2021 12:36:33
 
Так не перебрасывает, если изначально остаток больше нуля.
Код
Option Explicit
'v2
Sub Переброска()
    Dim arr As Variant
    arr = GetArr(ActiveSheet)
    Dim orr As Variant
    orr = GetOutArr(arr)
    OutArr orr
End Sub
 
Sub OutArr(arr As Variant)
    If Not IsEmpty(arr) Then
        With Workbooks.Add(1).Sheets(1).Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
            .Columns(1).NumberFormat = "@"
            .Columns(1).AutoFit
            .Cells = arr
            .Columns(1).AutoFit
        End With
    End If
End Sub
 
Function GetOutArr(arr As Variant) As Variant
    Dim y As Long
    Dim x As Integer
    Dim k As Integer
    Dim crr As Variant
    crr = arr
    Dim brr As Variant
    Dim b As Long
    Dim i As Byte
    For i = 0 To 1
        For y = 5 To UBound(arr, 1)
            For x = 3 To UBound(arr, 2) - 1 Step 2
                If True Then
                    If arr(y, x) > arr(y, x + 1) Then
                        For k = 3 To UBound(arr, 2) - 1 Step 2
                            If k <> x Then
                                If arr(y, x) > arr(y, x + 1) Then
                                    If arr(y, k) < arr(y, k + 1) Then
                                        If crr(y, k) = 0 Then
                                            arr(y, x) = arr(y, x) - 1
                                            arr(y, k) = arr(y, k) + 1
                                             
                                            b = b + 1
                                            If i = 0 Then
                                            Else
                                                brr(b, 1) = arr(y, 1)
                                                brr(b, 2) = arr(y, 2)
                                                brr(b, 3) = arr(2, x)
                                                brr(b, 4) = arr(2, k)
                                                brr(b, 5) = 1
                                            End If
                                        End If
                                    End If
                                Else
                                    Exit For
                                End If
                            End If
                        Next
                    End If
                End If
            Next
        Next
        If i = 0 Then
            If b = 0 Then
                Exit For
            Else
                ReDim brr(1 To b, 1 To 5)
                b = 0
                arr = crr
            End If
        End If
    Next i
    GetOutArr = brr
End Function
 
Function GetArr(sh As Worksheet) As Variant
    With sh
        Dim y As Long
        Dim x As Integer
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        x = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
        GetArr = .Range(.Cells(1, 1), .Cells(y, x))
    End With
End Function
 
Да, верно так лучше. Спасибо!
Сделайте пожалуйста, чтобы товар забирался с магазина с наибольшим свободным остатком (остаток минус продажа)
 
Так забирает из наибольшего остатка.
Код
Option Explicit
'v3
Sub Переброска()
    Dim arr As Variant
    arr = GetArr(ActiveSheet)
    Dim orr As Variant
    orr = GetOutArr(arr)
    OutArr orr
End Sub
 
Sub OutArr(arr As Variant)
    If Not IsEmpty(arr) Then
        With Workbooks.Add(1).Sheets(1).Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
            .Columns(1).NumberFormat = "@"
            .Columns(1).AutoFit
            .Cells = arr
            .Columns(1).AutoFit
        End With
    End If
End Sub
 
Function GetOutArr(arr As Variant) As Variant
    Dim y As Long
    Dim x As Integer
    Dim maxX As Integer
    Dim k As Integer
    Dim crr As Variant
    crr = arr
    Dim brr As Variant
    Dim b As Long
    Dim i As Byte
    Dim flag As Boolean
    Dim fla2 As Boolean
    For i = 0 To 1
        For y = 5 To UBound(arr, 1)
            Do
                maxX = 3
                flag = False
                fla2 = False
                For x = 3 To UBound(arr, 2) - 1 Step 2
                    If arr(y, maxX) - arr(y, maxX + 1) < arr(y, x) - arr(y, x + 1) Then
                        maxX = x
                    End If
                    If crr(y, x) = 0 Then If arr(y, x) < arr(y, x + 1) Then flag = True
                    If arr(y, x) > arr(y, x + 1) Then fla2 = True
                Next
                If fla2 = False Then Exit Do
                
                If flag Then
                    x = maxX
                    If arr(y, x) > arr(y, x + 1) Then
                        For k = 3 To UBound(arr, 2) - 1 Step 2
                            If k <> x Then
                                If arr(y, x) > arr(y, x + 1) Then
                                    If arr(y, k) < arr(y, k + 1) Then
                                        If crr(y, k) = 0 Then
                                            arr(y, x) = arr(y, x) - 1
                                            arr(y, k) = arr(y, k) + 1
                                             
                                            b = b + 1
                                            If i = 0 Then
                                            Else
                                                brr(b, 1) = arr(y, 1)
                                                brr(b, 2) = arr(y, 2)
                                                brr(b, 3) = arr(2, x)
                                                brr(b, 4) = arr(2, k)
                                                brr(b, 5) = 1
                                            End If
                                        End If
                                    End If
                                Else
                                    Exit For
                                End If
                            End If
                        Next
                    End If
                Else
                    Exit Do
                End If
            Loop
            
'            For x = 3 To UBound(arr, 2) - 1 Step 2
'                If True Then
'                    If arr(y, x) > arr(y, x + 1) Then
'                        For k = 3 To UBound(arr, 2) - 1 Step 2
'                            If k <> x Then
'                                If arr(y, x) > arr(y, x + 1) Then
'                                    If arr(y, k) < arr(y, k + 1) Then
'                                        If crr(y, k) = 0 Then
'                                            arr(y, x) = arr(y, x) - 1
'                                            arr(y, k) = arr(y, k) + 1
'
'                                            b = b + 1
'                                            If i = 0 Then
'                                            Else
'                                                brr(b, 1) = arr(y, 1)
'                                                brr(b, 2) = arr(y, 2)
'                                                brr(b, 3) = arr(2, x)
'                                                brr(b, 4) = arr(2, k)
'                                                brr(b, 5) = 1
'                                            End If
'                                        End If
'                                    End If
'                                Else
'                                    Exit For
'                                End If
'                            End If
'                        Next
'                    End If
'                End If
'            Next
        Next
        If i = 0 Then
            If b = 0 Then
                Exit For
            Else
                ReDim brr(1 To b, 1 To 5)
                b = 0
                arr = crr
            End If
        End If
    Next i
    GetOutArr = brr
End Function
 
Function GetArr(sh As Worksheet) As Variant
    With sh
        Dim y As Long
        Dim x As Integer
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        x = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
        GetArr = .Range(.Cells(1, 1), .Cells(y, x))
    End With
End Function
 
Прикрепил файл с результатом. Забирается верно, но результат дублируется.  
 
Это не дубль. Это перемещение до тех пор, пока остаток не сравняется с продажами.
Забирает 1 шт в соответствии с "количество забираемых позиций (сколько) всегда 1".
 
Вангую
Код
Option Explicit
'v5
Sub Переброска()
    Dim arr As Variant
    arr = GetArr(ActiveSheet)
    Dim orr As Variant
    orr = GetOutArr(arr)
    OutArr orr
End Sub
  
Sub OutArr(arr As Variant)
    If Not IsEmpty(arr) Then
        With Workbooks.Add(1).Sheets(1).Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
            .Columns(1).NumberFormat = "@"
            .Columns(1).AutoFit
            .Cells = arr
            .Columns(1).AutoFit
        End With
    End If
End Sub
  
Function GetOutArr(arr As Variant) As Variant
    Dim y As Long
    Dim x As Integer
    Dim maxX As Integer
    Dim k As Integer
    Dim crr As Variant
    crr = arr
    Dim brr As Variant
    Dim b As Long
    Dim i As Byte
    Dim flag As Boolean
    Dim fla2 As Boolean
    For i = 0 To 1
        For y = 5 To UBound(arr, 1)
            Do
                maxX = 3
                flag = False
                fla2 = False
                For x = 3 To UBound(arr, 2) - 1 Step 2
                    If arr(y, maxX) - arr(y, maxX + 1) < arr(y, x) - arr(y, x + 1) Then
                        maxX = x
                    End If
                    If arr(y, x) = 0 Then If arr(y, x) < arr(y, x + 1) Then flag = True
                    If arr(y, x) > arr(y, x + 1) Then fla2 = True
                Next
                If fla2 = False Then Exit Do
                 
                If flag Then
                    x = maxX
                    If arr(y, x) > arr(y, x + 1) Then
                        For k = 3 To UBound(arr, 2) - 1 Step 2
                            If k <> x Then
                                If arr(y, x) > arr(y, x + 1) Then
                                    If arr(y, k) < arr(y, k + 1) Then
                                        If arr(y, k) = 0 Then
                                            arr(y, x) = arr(y, x) - 1
                                            arr(y, k) = arr(y, k) + 1
                                              
                                            b = b + 1
                                            If i = 0 Then
                                            Else
                                                brr(b, 1) = arr(y, 1)
                                                brr(b, 2) = arr(y, 2)
                                                brr(b, 3) = arr(2, x)
                                                brr(b, 4) = arr(2, k)
                                                brr(b, 5) = 1
                                            End If
                                        End If
                                    End If
                                Else
                                    Exit For
                                End If
                            End If
                        Next
                    End If
                Else
                    Exit Do
                End If
            Loop
        Next
        If i = 0 Then
            If b = 0 Then
                Exit For
            Else
                ReDim brr(1 To b, 1 To 5)
                b = 0
                arr = crr
            End If
        End If
    Next i
    GetOutArr = brr
End Function
  
Function GetArr(sh As Worksheet) As Variant
    With sh
        Dim y As Long
        Dim x As Integer
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        x = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
        GetArr = .Range(.Cells(1, 1), .Cells(y, x))
    End With
End Function
 
Правильно я думаю макрос выбирает максимальную ячейку только один раз, и потом расходует её пока не обнулит. Получается для случая в приложении (последняя строка) товар7 забирается только из магазина4 пока в итоге там не будет 0. А магазин5 остаётся не расходованным.
Хотя когда мы забрали из магазина4 одну единицу, он уже не стал магазином с наибольшим остатком. Есть возможность совершенствовать? Таким образом, чтобы каждый раз товар забирался из магазина с наибольшим свободным остатком (остаток минус продажа).
Изменено: vikttur - 11.10.2021 15:45:58
 
Код
Option Explicit
'v6
Sub Переброска()
    Dim arr As Variant
    arr = GetArr(ActiveSheet)
    Dim orr As Variant
    orr = GetOutArr(arr)
    OutArr orr
End Sub
   
Sub OutArr(arr As Variant)
    If Not IsEmpty(arr) Then
        With Workbooks.Add(1).Sheets(1).Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
            .Columns(1).NumberFormat = "@"
            .Columns(1).AutoFit
            .Cells = arr
            .Columns(1).AutoFit
        End With
    End If
End Sub
   
Function GetOutArr(arr As Variant) As Variant
    Dim y As Long
    Dim x As Integer
    Dim maxX As Integer
    Dim k As Integer
    Dim crr As Variant
    crr = arr
    Dim brr As Variant
    Dim b As Long
    Dim i As Byte
    Dim flag As Boolean
    Dim fla2 As Boolean
    For i = 0 To 1
        For y = 5 To UBound(arr, 1)
            Do
                maxX = 3
                flag = False
                fla2 = False
                For x = 3 To UBound(arr, 2) - 1 Step 2
                    If arr(y, maxX) - arr(y, maxX + 1) < arr(y, x) - arr(y, x + 1) Then
                        maxX = x
                    End If
                    If arr(y, x) = 0 Then If arr(y, x) < arr(y, x + 1) Then flag = True
                    If arr(y, x) > arr(y, x + 1) Then fla2 = True
                Next
                If fla2 = False Then Exit Do
                  
                If flag Then
                    x = maxX
                    If arr(y, x) > arr(y, x + 1) Then
                        For k = 3 To UBound(arr, 2) - 1 Step 2
                            If k <> x Then
                                If arr(y, x) > arr(y, x + 1) Then
                                    If arr(y, k) < arr(y, k + 1) Then
                                        If arr(y, k) = 0 Then
                                            arr(y, x) = arr(y, x) - 1
                                            arr(y, k) = arr(y, k) + 1
                                               
                                            b = b + 1
                                            If i = 0 Then
                                            Else
                                                brr(b, 1) = arr(y, 1)
                                                brr(b, 2) = arr(y, 2)
                                                brr(b, 3) = arr(2, x)
                                                brr(b, 4) = arr(2, k)
                                                brr(b, 5) = 1
                                                Exit For
                                            End If
                                        End If
                                    End If
                                Else
                                    Exit For
                                End If
                            End If
                        Next
                    End If
                Else
                    Exit Do
                End If
            Loop
        Next
        If i = 0 Then
            If b = 0 Then
                Exit For
            Else
                ReDim brr(1 To b, 1 To 5)
                b = 0
                arr = crr
            End If
        End If
    Next i
    GetOutArr = brr
End Function
   
Function GetArr(sh As Worksheet) As Variant
    With sh
        Dim y As Long
        Dim x As Integer
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        x = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
        GetArr = .Range(.Cells(1, 1), .Cells(y, x))
    End With
End Function
 
Пока вроде все верно, завтра с утра ещё внимательно протестирую, по результату отпишу.
Модераторы, извините за кривое название темы.
Предлагаю следующее название: "Макрос для переноса данных по по строке. С выгрузкой отчёта."
 
Цитата
МатросНаЗебре написал:
Option Explicit'v6Sub
Все работает отлично, нужна небольшая доработка, к сожалению был неправ, говоря, что надо оперировать со свободным остатком (остаток минус продажа)
Если на магазине продажи 5 и остаток 5 то с этого магазина товар не забирается хотя можно забрать 4 штуки оставив одну. т. остаток одной штуке на магазине с продажами вполне достаточно. Этот момент поддаётся исправлению? Чтобы если есть потребность для перемещения товар забирался до остатка 1 шт.
в прикреплённом файле отразил.

Тк же свободный остаток плохо когда на магазине остаток-2, а продажи-1, получается неперемещаемый остаток в магазина 2. При этом есть магазины с продажами вообще без остатка.  
Изменено: DrDreik А - 12.10.2021 04:03:40
 
DrDreik А, см. файл.
Модераторам, название темы:
Автоматизация перемещения единицы товара на магазины с нулевым остатком и продажами более нуля
Изменено: JayBhagavan - 11.10.2021 22:43:04 (замена файла)

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
Цитата
JayBhagavan написал:
DrDreik А , см. файл.
Все проверил, все отлично работает!  В процессе проверки появилась идея использовать верхнюю самую первую строку, для возможности переброски по рейтингу магазина.
Если в первой строке все единицы, переброска идёт слева на право, как это сейчас.
Если в первой строке проставлен рейтинг магазинов переброска идёт в порядке рейтинга от наименьшего к большему
Если в первой строке во всех колонках стоит R, переброска идёт не слева направо, а случайным образом Random
Я так думаю что, для этого необходимо в самом начале перемешать магазины согласно условию которое стоит в первой строке. А дальше уже макрос работает как и уже есть. Если есть возможность добавьте пожалуйста эту функцию. Тут сложность в том, что столбец магазина содержит объединённые и не сортируется обычной сортировкой.
Страницы: 1 2 След.
Наверх