Страницы: 1
RSS
Наиболее частое сочетание наименований, Как определить кол-во наиболее частых сочетаний наименований?
 
Есть данные чеков с видами купленной продукции. В одном чеке может быть один вид продукции, и также может быть несколько.
Необходимо понять какие сочетания продуктов покупают чаще?

В файле примера, маленький список чеков, (их кол-во может доходить до 1000).
 
Код
Sub Yogurt()
    Dim arr As Variant
    arr = Range("G3:M3").Value
    
    Dim brr As Variant
    brr = Range("A3:B20").Value
    
    Dim crr As Variant
    ReDim crr(1 To UBound(arr, 2), 1 To UBound(arr, 2))
    
    Dim dicX As Object
    Set dicX = CreateObject("Scripting.Dictionary")
    
    Dim ya As Long
    For ya = 1 To UBound(arr, 2)
        dicX(arr(1, ya)) = ya
    Next
    
    Dim yy As Long
    Dim xx As Long
    Dim yb As Long
    Dim yf As Long
    Dim yc As Long
    For yb = 1 To UBound(brr, 1)
        For yf = yb + 1 To UBound(brr, 1)
            If brr(yf, 1) <> brr(yb, 1) Then Exit For
        Next
        yf = yf - 1
        If yf > yb Then
            For yc = yb + 1 To yf
                If dicX.Exists(brr(yb, 2)) Then
                    If dicX.Exists(brr(yc, 2)) Then
                        yy = dicX(brr(yb, 2))
                        xx = dicX(brr(yc, 2))
                        crr(yy, xx) = crr(yy, xx) + 1
                        If yy <> xx Then
                            crr(xx, yy) = crr(xx, yy) + 1
                        End If
                    End If
                End If
            Next
        End If
    Next
    
    Range("G4").Resize(UBound(crr, 1), UBound(crr, 2)).Value = crr
End Sub
 
Цитата
написал:
Sub Yogurt()
   Dim arr As Variant
   arr = Range("G3:M3").Value
   
   Dim brr As Variant
   brr = Range("A3:B20").Value
   
   Dim crr As Variant
   ReDim crr(1 To UBound(arr, 2), 1 To UBound(arr, 2))
   
   Dim dicX As Object
   Set dicX = CreateObject("Scripting.Dictionary")
   
   Dim ya As Long
   For ya = 1 To UBound(arr, 2)
       dicX(arr(1, ya)) = ya
   Next
   
   Dim yy As Long
   Dim xx As Long
   Dim yb As Long
   Dim yf As Long
   Dim yc As Long
   For yb = 1 To UBound(brr, 1)
       For yf = yb + 1 To UBound(brr, 1)
           If brr(yf, 1) <> brr(yb, 1) Then Exit For
       Next
       yf = yf - 1
       If yf > yb Then
           For yc = yb + 1 To yf
               If dicX.Exists(brr(yb, 2)) Then
                   If dicX.Exists(brr(yc, 2)) Then
                       yy = dicX(brr(yb, 2))
                       xx = dicX(brr(yc, 2))
                       crr(yy, xx) = crr(yy, xx) + 1
                       If yy <> xx Then
                           crr(xx, yy) = crr(xx, yy) + 1
                       End If
                   End If
               End If
           Next
       End If
   Next
   
   Range("G4").Resize(UBound(crr, 1), UBound(crr, 2)).Value = crr
End Sub
Скажите, а только макросом это возможно? Формулами ни как?
 
Добрый день!
Вот интересная статья на по вашей теме. Ассоциативные правила
Для тысячи чеков и видов продукции может быть получится и вручную сделать, довольно трудоемко, кажется. Приложил маленький пример.  
 
Rina19102017, добрый день. Еще вариант с Power Pivot.
Изменено: Alex - 08.10.2024 16:41:47
 
Цитата
написал:
Еще вариант с Power Pivot.
Спасибо, но у меня открывает как сводную таблицу и всё(
 
Rina19102017, так результат расчета меры и выводится в сводную таблицу, саму модель данных можно увидеть, если версия Эксель поддерживает Power Pivot.
 
Alex, поняла, у меня 365. Но Pivot ещё не пользовалась, теперь есть, что поизучать.
Спасибо большое за отклик.  
 
Цитата
Rina19102017:  Формулами ни как? ...у меня 365
формула
Страницы: 1
Наверх