Combinazioni

[giorgioa]

Salve e buongiorno a tutti
data la mia incapacità di creare macro in VBA per Excel
chiedo se possibile esserne scritta una aventi le seguenti caratteristiche:
1-trattasi di numeri;
2-per combinazioni di terno o quaterna o cinquina oppure sestina (a mia scelta);
3-i numeri devono essere indicati da me (cioè 3-4-7-11-14-17-30-40-90 ecc possibile anche tutti però sempre da me
indicati).
Ringraziando dell'aiuto saluto

[Flash30005]

Non sarebbe complicato realizzare quello che chiedi
complicato è dove mettere oltre 622 milioni di combinazioni nel caso volessi tutte le sestine esistenti con 90 numeri

[giorgioa]

Salve Flash,
ho aggiunto anche "TUTTI" solo per non limitare la quantità di numeri
ma in effetti l'uso dei numeri sarà limitato.
Mi son detto abbondiamo.
salve

[Flash30005]

Apri una nuova cartella di excel
aggiungi due fogli
Il primo foglio lo lasci con il nome Foglio1
il secondo rinominalo in "T" (= Terzine)
il terzo "Q"
il quarto "C"
il Quinto "S"
tutti senza apici
Ora nel foglio1 colonna A da A1 a A fino dove vuoi (ma non esagerare) inserirai i numeri da combinare
In D1 crei una convalida con elenco 3;4;5;6
In G1 inserisci questa formula

Codice: Seleziona tutto

=(FATTORIALE(CONTA.VALORI(A1:A90))/(FATTORIALE(CONTA.VALORI(A1:A90)-D1)))/FATTORIALE(D1)

per avere immediatamente il numero delle combinazioni e stabilire così se procedere allo sviluppo.

Inserisci questa macro in un moulo

Codice: Seleziona tutto

Sub Combin()
Set Ws1 = Sheets("Foglio1")
UR1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
CombN = Ws1.Range("D1").Value
Select Case CombN
Case 3
NomeF = "T"
Case 4
NomeF = "Q"
Case 5
NomeF = "C"
Case 6
NomeF = "S"
Case Else
Exit Sub
End Select
Application.ScreenUpdating = False
Application.Calculation = xlManual
Set Ws2 = Sheets(NomeF)
Ws2.Cells.ClearContents
For RR1 = 1 To UR1 - (CombN - 1)
    For RR2 = RR1 + 1 To UR1 - (CombN - 2)
        For RR3 = RR2 + 1 To UR1 - (CombN - 3)
            If CombN = 3 Then
                UR2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
                Ws2.Range("A" & UR2).Value = Ws1.Range("A" & RR1).Value
                Ws2.Range("B" & UR2).Value = Ws1.Range("A" & RR2).Value
                Ws2.Range("C" & UR2).Value = Ws1.Range("A" & RR3).Value
            GoTo salta3
            End If
            For RR4 = RR3 + 1 To UR1 - (CombN - 4)
                If CombN = 4 Then
                    UR2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
                    Ws2.Range("A" & UR2).Value = Ws1.Range("A" & RR1).Value
                    Ws2.Range("B" & UR2).Value = Ws1.Range("A" & RR2).Value
                    Ws2.Range("C" & UR2).Value = Ws1.Range("A" & RR3).Value
                    Ws2.Range("D" & UR2).Value = Ws1.Range("A" & RR4).Value
                    GoTo salta4
                End If
                For RR5 = RR4 + 1 To UR1 - (CombN - 5)
                    If CombN = 5 Then
                        UR2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
                        Ws2.Range("A" & UR2).Value = Ws1.Range("A" & RR1).Value
                        Ws2.Range("B" & UR2).Value = Ws1.Range("A" & RR2).Value
                        Ws2.Range("C" & UR2).Value = Ws1.Range("A" & RR3).Value
                        Ws2.Range("D" & UR2).Value = Ws1.Range("A" & RR4).Value
                        Ws2.Range("E" & UR2).Value = Ws1.Range("A" & RR5).Value
                        GoTo salta5
                    End If
                    For RR6 = RR5 + 1 To UR1 - (CombN - 6)
                        UR2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
                        Ws2.Range("A" & UR2).Value = Ws1.Range("A" & RR1).Value
                        Ws2.Range("B" & UR2).Value = Ws1.Range("A" & RR2).Value
                        Ws2.Range("C" & UR2).Value = Ws1.Range("A" & RR3).Value
                        Ws2.Range("D" & UR2).Value = Ws1.Range("A" & RR4).Value
                        Ws2.Range("E" & UR2).Value = Ws1.Range("A" & RR5).Value
                        Ws2.Range("F" & UR2).Value = Ws1.Range("A" & RR6).Value
                    Next RR6
salta5:
                Next RR5
salta4:
            Next RR4
salta3:
        Next RR3
    Next RR2
Next RR1
Ws2.Rows("1:1").Delete Shift:=xlUp
Ws2.Select
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub


Nel foglio1 inserisci un comando per attivare la macro

Ciao

[giorgioa]

Un sentito ringraziamento al
Sig. Flash.
Sono in dovere di farlo perchè lo merita.
La macro "Combinazioni" funziona PERFETTAMENTE.
Grazie e saluti