Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Формула соединения парного товара по точкам, Соединить одиночные позиции по магазинам для ПАРНОЙ продажи
 
Добрый день, коллеги.
Помогите придумать формулу.

Имеется товар, который продается только парами, но на некоторых магазинах он находится по 1 шт.
Я вывел огромную таблицу более чем на 10000 позиций по 1 шт. на разных магазинах.
Хотелось бы формулой соединить эти пары вместе для наилучшей продажи. Уже всю голову сломал, пробовал заходить с разных углов, никак не получается.

Пример таблицы во вложении и что должно получиться.
Главная цель: создать ниже удобную таблицу для сортировки и создания перемещений.
Изменено: Дмитрий Костеров - 30 мар 2021 10:33:16
 
Решение нужно исключительно формулами?
И по какому принципу нужно определять отправителя и получателя? Например, почему именно из Москвы в Находку, а не наоборот?
Что делать, если в трёх городах по одной штуке? Как формировать пару?
 
А где размеры обуви, а то соедините 40 с 45
 
Цитата
msi2102 написал:
где размеры обуви, а то соедините 40 с 45
На самом деле там другой товар, он более универсальный, поэтому дополнительный отбор по размеру не требуется
 
Цитата
Юрий М написал:
Решение нужно исключительно формулами?И по какому принципу нужно определять отправителя и получателя? Например, почему именно из Москвы в Находку, а не наоборот?Что делать, если в трёх городах по одной штуке? Как формировать пару?
Можно макросом, но мне кажется он сильно подгрузит систему, таблица очень большая.
Отправитель и получатель определяется по наличию 1 шт. Грубо говоря нужно соединить две точки у которых есть 1 шт. Не важно если будет отправитель - получатель либо получатель-отправитель. Главное соединить пары.
Если 3 шт. то соединить первые две точки, третью подписать «Без пары»
 
Пишу в личку.
 
Передумал: заказ свободен.
 
Если макрос устроит, то я возьмусь.
 
эх, а я уже макрос написал )))
 
Автор ошибся разделом )
 
эх, вот так всегда))
ладно, вот макрос. В файле на активном листе с таблицей с данными нажмите ALT+F8 - Выполнить

Код
Sub НайтиПары()
Dim arrData, iRow As Long, iCol As Long, arrResult, iRowRes As Long, iColRes As Long, iCode As String, iName As String, iCity As String, iCounter As Long

    arrData = Range("A1").CurrentRegion 'вся таблица с данными
    ReDim arrResult(1 To UBound(arrData, 1), 1 To 6) 'массив под результат
    For iCol = 2 To UBound(arrData, 2) 'по столбцам
        For iRow = 3 To UBound(arrData, 1) 'по строкам
            If arrData(iRow, iCol) = 1 Then
                iCounter = iCounter + 1 'счётчик найденного товара
                If iCounter = 1 Then
                    iCode = arrData(1, iCol) 'запоминаем код товара
                    iName = arrData(2, iCol) 'запоминаем название товара
                    iCity = arrData(iRow, 1) 'запоминаем город товара
                End If
                If iCounter = 2 Then 'если нашли пару
                    iRowRes = iRowRes + 1
                    arrResult(iRowRes, 1) = iCity 'отправитель
                    arrResult(iRowRes, 2) = arrData(iRow, 1) 'получатель
                    arrResult(iRowRes, 3) = iCode 'код товара
                    arrResult(iRowRes, 4) = iName 'наименование
                    arrResult(iRowRes, 5) = 1 'кол-во
                    arrResult(iRowRes, 6) = iCity & "-" & arrData(iRow, 1) & ". Перемещение на пополнение" 'комментарий
                    iCounter = 0
                End If
            End If
        Next iRow
        If iCounter = 1 Then 'не нашли пару
            iRowRes = iRowRes + 1
            arrResult(iRowRes, 1) = iCity 'отправитель
            arrResult(iRowRes, 2) = "Нет пары" 'получатель
            arrResult(iRowRes, 3) = iCode 'код товара
            arrResult(iRowRes, 4) = iName 'наименование
            arrResult(iRowRes, 5) = 1 'кол-во
            arrResult(iRowRes, 6) = "Нет пары" 'комментарий
        End If
        iCounter = 0 'сбрасываем счётчик
    Next iCol
    Worksheets.Add
    [A1] = "Отправитель": [B1] = "Получатель": [C1] = "Код": [D1] = "Наименование": [E1] = "Кол-во": [F1] = "Наименование"
    Range("A2").Resize(UBound(arrResult, 1), UBound(arrResult, 2)).Value = arrResult
End Sub
Изменено: New - 30 мар 2021 13:18:02
 
Ну не выбрасывать же ).
Код
Sub ВаленкиВаленки()
    Const sRANGE = "A1:J35"
    Const BUFF_SIZE = 1000
    
    Dim arr As Variant
    arr = ActiveSheet.Range(sRANGE)
    
    Dim aOu As Variant
    ReDim aOu(1 To BUFF_SIZE, 1 To 6)
    
    Dim sh As Worksheet
    Set sh = Workbooks.Add(1).Sheets(1)
    sh.Cells(1, 1).Resize(1, 6) = Array("Отправитель", "Получатель", "Код товара", "Наимен.", "Кол-во", "Комментарий")
    
    Dim f As Boolean
    Dim y As Long
    Dim u As Integer
    Dim x As Integer
    For x = 2 To UBound(arr, 2)
        f = True
        For y = 3 To UBound(arr, 1)
            If arr(y, x) = 1 Then
                If f Then
                    u = u + 1
                    If u > UBound(aOu, 1) Then
                        OutArray aOu, sh
                        u = 1
                        ReDim aOu(1 To BUFF_SIZE, 1 To 6)
                    End If
                    aOu(u, 1) = arr(y, 1)
                    aOu(u, 3) = arr(1, x)
                    aOu(u, 4) = arr(2, x)
                    aOu(u, 5) = 1
                Else
                    aOu(u, 2) = arr(y, 1)
                    aOu(u, 6) = aOu(u, 1) & " - " & aOu(u, 2) & ". Перемещение на пополнение."
                End If
                f = Not f
            End If
            If Not f Then
                aOu(u, 2) = "Нет пары"
                aOu(u, 6) = "Нет пары"
            End If
        Next
    Next
    
    OutArray aOu, sh
    sh.Parent.Saved = True
End Sub

Sub OutArray(aOu As Variant, sh As Worksheet)
    With sh
        .Cells(.Rows.Count, 1).End(xlUp).Cells(2, 1).Resize(UBound(aOu, 1), UBound(aOu, 2)) = aOu
    End With
End Sub
Изменено: МатросНаЗебре - 30 мар 2021 12:38:29
 
А ещё нужно расстояние между пунктами отправки, чтобы правильно составить логистику и не везти во Владивосток из Астрахани если можно привезти из Находки :D  
Изменено: msi2102 - 30 мар 2021 12:53:20
 
Черт побери, да вы мать его, гении. Я не успел с работы приехать, а вы уже макросы сделали. Всё работает, идеально.Ребята скиньте в личку какие-нибудь данные, я хоть отправлю вам на пиво )
 
да, ладно. я пасс, спасибо. Мы всегда рады помочь людям )
P.S. В следующий раз не ошибайтесь разделом - Раздел Работа - там платные заказы
Изменено: New - 30 мар 2021 13:26:10
Страницы: 1
Читают тему (гостей: 1)
Наверх