Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Формула соединения парного товара по точкам, Соединить одиночные позиции по магазинам для ПАРНОЙ продажи
 
#1
30.03.2021 10:32:33
Добрый день, коллеги.
Помогите придумать формулу.

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

Пример таблицы во вложении и что должно получиться.
Главная цель: создать ниже удобную таблицу для сортировки и создания перемещений.
Изменено: Дмитрий Костеров - 30.03.2021 10:33:16
 
 
 
#2
30.03.2021 10:50:14
Решение нужно исключительно формулами?
И по какому принципу нужно определять отправителя и получателя? Например, почему именно из Москвы в Находку, а не наоборот?
Что делать, если в трёх городах по одной штуке? Как формировать пару?
 
 
 
#3
30.03.2021 11:03:27
А где размеры обуви, а то соедините 40 с 45
 
 
 
#4
30.03.2021 11:21:44
Цитата
msi2102 написал:
где размеры обуви, а то соедините 40 с 45
На самом деле там другой товар, он более универсальный, поэтому дополнительный отбор по размеру не требуется
 
 
 
#5
30.03.2021 11:29:35
Цитата
Юрий М написал:
Решение нужно исключительно формулами?И по какому принципу нужно определять отправителя и получателя? Например, почему именно из Москвы в Находку, а не наоборот?Что делать, если в трёх городах по одной штуке? Как формировать пару?
Можно макросом, но мне кажется он сильно подгрузит систему, таблица очень большая.
Отправитель и получатель определяется по наличию 1 шт. Грубо говоря нужно соединить две точки у которых есть 1 шт. Не важно если будет отправитель - получатель либо получатель-отправитель. Главное соединить пары.
Если 3 шт. то соединить первые две точки, третью подписать «Без пары»
 
 
 
#6
30.03.2021 11:40:54
Пишу в личку.
 
 
 
#7
30.03.2021 12:02:51
Передумал: заказ свободен.
 
 
 
#8
30.03.2021 12:08:02
Если макрос устроит, то я возьмусь.
 
 
 
#9
30.03.2021 12:12:17
эх, а я уже макрос написал )))
 
 
 
#10
30.03.2021 12:16:01
Автор ошибся разделом )
 
 
 
#11
30.03.2021 12:21:23
эх, вот так всегда))
ладно, вот макрос. В файле на активном листе с таблицей с данными нажмите 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.03.2021 13:18:02
 
 
 
#12
30.03.2021 12:37:40
Ну не выбрасывать же ).
Код
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.03.2021 12:38:29
 
 
 
#13
30.03.2021 12:45:46
А ещё нужно расстояние между пунктами отправки, чтобы правильно составить логистику и не везти во Владивосток из Астрахани если можно привезти из Находки :D  
Изменено: msi2102 - 30.03.2021 12:53:20
 
 
 
#14
30.03.2021 12:57:36
Черт побери, да вы мать его, гении. Я не успел с работы приехать, а вы уже макросы сделали. Всё работает, идеально.Ребята скиньте в личку какие-нибудь данные, я хоть отправлю вам на пиво )
 
 
 
#15
30.03.2021 13:24:32
да, ладно. я пасс, спасибо. Мы всегда рады помочь людям )
P.S. В следующий раз не ошибайтесь разделом - Раздел Работа - там платные заказы
Изменено: New - 30.03.2021 13:26:10
 
 
 
Страницы: 1
Наверх