Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Как выписать цепочку данных по определенному артикулу, если они связаны друг с другом?
 
#1
20.01.2021 11:04:22
У нас есть сайт, который к определенному товару при его выборе дает рекомендацию приобрести дополняющий его товар (к примеру мы выбрали чайник, нам предлагается положить в карзину прихватку, кружки для чая и т.п.).

Суть задачи заключается в том, чтобы в один массив достать все связанные друг с другом артикулы. Например, если мы берем изначальный артикул чайника, то нам должны вытащиться артикулы прихватки, кружек, и т.п. а также всех тех артикулов, которые в свою очередь связаны с прихваткой и кружками, например кастрюля и ложки и так далее пока эта цепочка не замкнется.

Во вложении я закрепил файл, где показан список артикулов (упрощенный). Они завязаны друг с другом. Если у кого-то есть идеи как это сделать, то было бы очень круто!
Изменено: Никита Королев - 20.01.2021 11:55:48
 
 
 
#2
20.01.2021 11:07:55
Никита Королев, а есть вид того что вы хотите получить на выходе ?покажите в файле (замените ранее прикрепленный)
пы.сы  нет таких артикулов
Цитата
артикул чайника
Изменено: Mershik - 20.01.2021 11:15:38
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#3
20.01.2021 12:00:26
Mershik, заменил файл. Артикулы нормальные не могу проставить, но как мне кажется в роли упрощенной модели подойдет. На выходе должна получиться вся цепочка связанных друг с другом как показано в файле.
 
 
 
#4
20.01.2021 12:47:13
На VBA можно изобразить. Все подогнано строго под пример, поэтому если данные реальные отличаются - подгоняйте под свою структуру:
Код
Option Explicit
Dim dic As Object

Sub main()
    Dim arr, sArt$, s$
    Dim lr&, lc&, llastc&, llastr&
    Set dic = CreateObject("scripting.dictionary")
    dic.comparemode = 1
    
    With ActiveSheet
        sArt = .Range("H3").Value
        If Len(sArt) = 0 Then Exit Sub
        
        dic.Add sArt, 0&
        llastr = .Cells(.Rows.Count, 1).End(xlUp).Row
        llastc = 4
        arr = .Cells(3, 1).Resize(llastr - 2, llastc).Value
    
        For lr = 1 To UBound(arr, 1)
            s = arr(lr, 1)
            If s = sArt Then
                For lc = 2 To UBound(arr, 2)
                    s = arr(lr, lc)
                    If Len(s) Then
                        If Not dic.exists(s) Then
                            dic.Add s, 0&
                            GetLinkedArt s, arr
                        End If
                    End If
                Next
                Exit For
            End If
        Next
        
        dic.Remove sArt
        .Range("H4").Resize(dic.Count, 1).Value = Application.Transpose(dic.keys)
    End With
End Sub
Function GetLinkedArt(sArt$, arr)
    Dim lr&, lc&, s$
    For lr = 1 To UBound(arr, 1)
        s = arr(lr, 1)
        If s = sArt Then
            For lc = 2 To UBound(arr, 2)
                s = arr(lr, lc)
                If Len(s) Then
                    If Not dic.exists(s) Then
                        dic.Add s, 0&
                        GetLinkedArt s, arr
                    End If
                End If
            Next
            Exit For
        End If
    Next
End Function
запускать процедуру main.
Изменено: Дмитрий(The_Prist) Щербаков - 20.01.2021 12:47:35 (файл не подгрузился)
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#5
20.01.2021 14:20:00
Дмитрий, спасибо большое!
Подскажите, пожалуйста, что необходимо поменять в коде, чтобы он начинал поиск не только по одному вписанному значению в ячейке H3, но и по другим значениям в данной строке, если их проставить правее, как показано в прикрепленном файле?Связанные артикулы (1).xlsm (18.29 КБ)  
 
 
 
#6
20.01.2021 14:32:36
Цитата
Никита Королев написал:
что необходимо поменять в коде
изначально лучше пример прикладывать, максимально отвечающий требованиям задачи, если сами не в силах эту задачу решить и возможное решение подстроить. Это на будущее. Переделывать каждый раз под новое "а у меня вот так" мало у кого желания возникает
Код
Dim dic As Object

Sub main()
    Dim arr, aarts, sArt$, s$
    Dim lr&, lc&, la&, llastc&, llastr&
    
    
    With ActiveSheet
        llastc = .Cells(3, .Columns.Count).End(xlToLeft).Column
        aarts = .Cells(3, 8).Resize(2, llastc - 7).Value
        For la = 1 To UBound(aarts, 2)
            sArt = aarts(1, la)
            Set dic = CreateObject("scripting.dictionary")
            dic.comparemode = 1
            If Len(sArt) Then
                dic.Add sArt, 0&
                llastr = .Cells(.Rows.Count, 1).End(xlUp).Row
                llastc = 4
                arr = .Cells(3, 1).Resize(llastr - 2, llastc).Value
            
                For lr = 1 To UBound(arr, 1)
                    s = arr(lr, 1)
                    If s = sArt Then
                        For lc = 2 To UBound(arr, 2)
                            s = arr(lr, lc)
                            If Len(s) Then
                                If Not dic.exists(s) Then
                                    dic.Add s, 0&
                                    GetLinkedArt s, arr
                                End If
                            End If
                        Next
                        Exit For
                    End If
                Next
                dic.Remove sArt
                If dic.Count > 0 Then
                    .Cells(4, la + 7).Resize(dic.Count, 1).Value = Application.Transpose(dic.keys)
                End If
            End If
        Next
    End With
End Sub
Function GetLinkedArt(sArt$, arr)
    Dim lr&, lc&, s$
    For lr = 1 To UBound(arr, 1)
        s = arr(lr, 1)
        If s = sArt Then
            For lc = 2 To UBound(arr, 2)
                s = arr(lr, lc)
                If Len(s) Then
                    If Not dic.exists(s) Then
                        dic.Add s, 0&
                        GetLinkedArt s, arr
                    End If
                End If
            Next
            Exit For
        End If
    Next
End Function
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#7
20.01.2021 15:09:12
Вы просто гений, спасибо!
 
 
 
Страницы: 1
Наверх