[EXCEL] Trovare quante volte compaiono determinate n-uple

[Syntony]

Salve,
ho un file in cui sono presenti due colonne tra le altre: codice articolo e id dell'ordine in cui è stato acquistato, ovviamente gli articoli possono comparire in diversi ordini.
Di seguito un esempio del file che ho e del file che vorrei avere.

https://rapidshare.com/files/1967989536/Esempio.xlsx

In pratica vorrei calcolare il numero delle volte in cui 2 prodotti (o 3, o 4) sono stati acquistati insieme (cioè hanno lo stesso id ordine)

[Flash30005]

Ciao Syntony e benvenuto nel Forum

Vorrei sapere se i dati inseriti nella colonna F del foglio "File di Input" sono presenti sin dall'origine oppure devi ricavarli?
Se sono presenti dall'origine dovresti avere anche le "combinazioni" per i gruppi di 3 articoli, quattro articoli etc.

Confermi?

Ciao

[Syntony]

Ciao, purtroppo non li ho ma devo ricavarli, nell'esempio l'ho fatto a mano perchè sono pochi, ma in realtà essendo molti di più avrei bisogno di una funzione che faccia questa cosa.

[Flash30005]

C'è un limite al numero di gruppi articoli (combinazioni)?
possono andare oltre 4?

[Syntony]

Ci possono essere n articoli venduti nello stesso ordine (id ordine uguale), n può essere anche grande: 20, 30.

Mentre le combinazioni da ricercare probabilmente sono coppie, terne, quaterne e cinquine, oltre è poco probabile.

[Flash30005]

Sicuramente si può fare meglio
la considero molto spartana ma... funziona

Codice: Seleziona tutto

Public UR1A, N1, N2, N3, N4, N5, NCo, ContaC, IniR As Integer, Ws1, Ws2 As Worksheet
Sub CompilaTab()
Application.ScreenUpdating = False
Application.Calculation = xlManual
Set Ws1 = Worksheets("File di Input")
Set Ws2 = Worksheets("FTab")
ContaC = 0
Ws1.Columns(11).ClearContents
UR1A = Ws1.Range("A" & Rows.Count).End(xlUp).Row
For RR1 = 2 To UR1A
EleA = Ws1.Range("A" & RR1)
UR1K = Ws1.Range("K" & Rows.Count).End(xlUp).Row + 1
For RR2 = 2 To UR1K
If Ws1.Range("K" & RR2).Value = EleA Then GoTo SaltaRR1
Next RR2
Ws1.Cells(Rows.Count, 11).End(xlUp).Offset(1, 0).Value = EleA
SaltaRR1:
Next RR1
Ws1.Select
Ws1.Columns("K:K").Sort Key1:=Range("K2"), Order1:=xlAscending, Header:=xlYes, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
Ws1.Columns("A:B").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

NCo = Ws2.Range("B1").Value
UR1K = Ws1.Range("K" & Rows.Count).End(xlUp).Row
Ws2.Range("A5:B1000").ClearContents
For RCo1 = 2 To UR1K - (NCo - 1)
    N1 = Ws1.Range("K" & RCo1).Value
    For RCo2 = RCo1 + 1 To UR1K - (NCo - 2)
        N2 = Ws1.Range("K" & RCo2).Value
        If NCo = 2 Then
        ContaCo
            If ContaC > 0 Then
                Ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = N1 & ";" & N2
                Ws2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Value = ContaC
            End If
            ContaC = 0
            GoTo SaltaR2
        End If
        For RCo3 = RCo2 + 1 To UR1K - (NCo - 3)
            N3 = Ws1.Range("K" & RCo3).Value
            If NCo = 3 Then
            ContaCo
            If ContaC > 0 Then
                Ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = N1 & ";" & N2 & ";" & N3
                Ws2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Value = ContaC
            End If
            ContaC = 0
            GoTo SaltaR3
            End If
            For RCo4 = RCo3 + 1 To UR1K - (NCo - 4)
                N4 = Ws1.Range("K" & RCo4).Value
                If NCo = 4 Then
                    ContaCo
                    If ContaC > 0 Then
                        Ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = N1 & ";" & N2 & ";" & N3 & ";" & N4
                        Ws2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Value = ContaC
                    End If
                    ContaC = 0
                    GoTo SaltaR4
                End If
                For RCo5 = RCo4 + 1 To UR1K
                    N5 = Ws1.Range("K" & RCo5).Value
                    ContaCo
                    If ContaC > 0 Then
                        Ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = N1 & ";" & N2 & ";" & N3 & ";" & N4 & ";" & N5
                        Ws2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Value = ContaC
                    End If
                    ContaC = 0
                Next RCo5
SaltaR4:
            Next RCo4
SaltaR3:
        Next RCo3
SaltaR2:
    Next RCo2
Next RCo1
Ws1.Columns("A:B").Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("A2") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
        :=xlSortNormal
Ws2.Select
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub ContaCo()
IniR = 2
    For RR1 = IniR To UR1A - (NCo - 1)
        IDN1 = Ws1.Range("B" & RR1).Value
        N1A = Ws1.Range("A" & RR1).Value
        For RR2 = RR1 + 1 To UR1A - (NCo - 2)
            N2A = Ws1.Range("A" & RR2).Value
            IDN2 = Ws1.Range("B" & RR2).Value
            If NCo = 2 Then
                If IDN1 = IDN2 And N1A = N1 And N2A = N2 Then
                    ContaC = ContaC + 1
                    IniR = RR2
                    GoTo SaltaRR1
                End If
            End If
            For RR3 = RR2 + 1 To UR1A - (NCo - 3)
                N3A = Ws1.Range("A" & RR3).Value
                IDN3 = Ws1.Range("B" & RR3).Value
                If NCo = 3 Then
                    If IDN1 = IDN2 And IDN1 = IDN3 And N1A = N1 And N2A = N2 And N3A = N3 Then
                        ContaC = ContaC + 1
                        IniR = RR3
                        GoTo SaltaRR1
                    End If
                End If
                For RR4 = RR3 + 1 To UR1A - (NCo - 4)
                    N4A = Ws1.Range("A" & RR4).Value
                    IDN4 = Ws1.Range("B" & RR4).Value
                    If NCo = 4 Then
                        If IDN1 = IDN2 And IDN1 = IDN3 And IDN1 = IDN4 And N1A = N1 And N2A = N2 And N3A = N3 And N4A = N4 Then
                            ContaC = ContaC + 1
                            IniR = RR4
                            GoTo SaltaRR1
                        End If
                    End If
                    For RR5 = RR4 + 1 To UR1A
                        N5A = Ws1.Range("A" & RR5).Value
                        IDN5 = Ws1.Range("B" & RR5).Value
                        If NCo = 5 Then
                            If IDN1 = IDN2 And IDN1 = IDN3 And IDN1 = IDN4 And IDN1 = IDN5 And N1A = N1 And N2A = N2 And N3A = N3 And N4A = N4 And N5A = N5 Then
                                ContaC = ContaC + 1
                                IniR = RR5
                                GoTo SaltaRR1
                            End If
                        End If
                    Next RR5
                Next RR4
            Next RR3
        Next RR2
SaltaRR1:
    Next RR1
End Sub

Rinomina il foglio output con nome "FTab"
Copia l'intera macro in un modulo e avvia solo la macro "CompilaTab" assegnando un pulsante, forma etc

oppure inserisci questo codice nel foglio "FTab"

Codice: Seleziona tutto

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$B$1" Then Exit Sub
CompilaTab
End Sub

Fai sapere

Ciao

P.s. Fai attenzione perché utilizzo la colonna "K" del "Foglio1" per creare un elenco univoco che occorre alla macro stessa
pertanto se hai dei dati su quella colonna si deve modificare il riferimento nella macro

[Syntony]

Ciao,

innanzitutto grazie mille per la pronta risposta!

Ho provato a fare come dici ma non succede nulla, o meglio quando clicco sulla forma dove ho assegnato la macro vedo che sta compiendo qualche azione, ma il foglio FTab rimane solo con la forma scelta.
Mentre crea 5 lettere (a,b,c,d,e) nella colonna K del foglio 1.
Probabilmente sbaglio qualcosa, non sono molto dentro le macro, quindi probabilmente salto qualche passaggio fondamentale.

Ciao e grazie ancora!

[Flash30005]

Forse non hai copiate le variabili "Public" in testa al modulo
comunque prova questo file

Puoi anche eliminare il comando perché è sufficiente variare il valore in B1 del foglio "FTab"

ciao