Rompicapo Excel: permutazioni automatiche

Question

Rompicapo Excel: permutazioni automatiche

Anonimo

Salve a tutti,

sono un nuovo utilizzatore di Excel. Partendo da un insieme di 8 elementi ABCDEFGH, volevo conoscere tutte le possibili combinazioni di 4 elementi di questo insieme (es. ABCD, ABCE, ABCF, ecc., se possibile in ordine alfabetico), senza considerare le combinazioni che si ripetono (quindi se conosco già ABCD non mi interessa conoscere DCBA).

So che il numero di combinazioni di questo tipo (permutazioni) è 70. Vorrei che il programma mi facesse vedere ognuna di queste combinazioni in 70 celle distinte.

Si tratta di un problema risolvibile con Excel?

Grazie a tutti quelli che cercheranno di risolverlo.

Domanda bloccata. Questa domanda è stata eseguita dalla community del supporto tecnico Microsoft. È possibile votare se è utile, ma non è possibile aggiungere commenti o risposte o seguire la domanda.

0 commenti

Risposta accettata dall'autore della domanda

Anonimo

Ciao Gabriele,

sono un nuovo utilizzatore di Excel. Partendo da un insieme di 8 elementi ABCDEFGH, volevo conoscere tutte le possibili combinazioni di 4 elementi di questo insieme (es. ABCD, ABCE, ABCF, ecc., se possibile in ordine alfabetico), senza considerare le combinazioni che si ripetono (quindi se conosco già ABCD non mi interessa conoscere DCBA).

So che il numero di combinazioni di questo tipo (permutazioni) è 70. Vorrei che il programma mi facesse vedere ognuna di queste combinazioni in 70 celle distinte.

Si tratta di un problema risolvibile con Excel?

Prova qualcosa del genere:

Nella cella A1 del Foglio1, immetti C (per creare combinazioni)
Mella cella A2, immetti 4 (per indicare il numero di elimenti)
Nelll'intervallo A3:H3, immetti gli otto valori dell'insieme
Alt+F11 per aprire l'editor di VBA
Alt+IMper inserire un nuovo modulo di codice
Nel nuovo modulo vuoto, incolla il seguente codice:

'=========>>

Option Explicit

Dim vAllItems As Variant

Dim Buffer() As String

Dim BufferPtr As Long

Dim Results As Worksheet

'\ Myrna Larson, July 25, 2000, Microsoft.Public.Excel.Misc

'\ Adapted to handle horizontal data set 7/11/2015

'--------->>

Public Sub ListPermutationsOrCombinations()

Dim WB As Workbook

Dim srcSH As Worksheet

Dim RngPop As Range

Dim RngTipo As Range, RngSetSize As Range

Dim PopSize As Long

Dim SetSize As Long

Dim Which As String

Dim n As Double

Const BufferSize As Long = 4096

Set WB = ThisWorkbook

Set srcSH = WB.Sheets("Foglio1")

With srcSH

Set RngTipo = .Range("A1")

Set RngSetSize = .Range("A2")

With .Range("A3")

Set RngPop = .Resize(1, .End(xlToRight).Column)

End With

Application.Goto Worksheets("Foglio1").Range("A1")

PopSize = RngPop.Cells.Count ' - 2

If PopSize < 2 Then GoTo DataError

SetSize = RngSetSize.Value

If SetSize > PopSize Then GoTo DataError

Which = UCase$(RngTipo.Value)

Select Case Which

Case "C"

n = Application.WorksheetFunction.Combin(PopSize, SetSize)

Case "P"

n = Application.WorksheetFunction.Permut(PopSize, SetSize)

Case Else

GoTo DataError

End Select

If n > Rows.Count Then GoTo DataError

Application.ScreenUpdating = False

With WB

Set Results = .Worksheets.Add(After:=.Sheets(.Worksheets.Count))

End With

vAllItems = Application.Transpose(RngPop.Value)

ReDim Buffer(1 To BufferSize) As String

BufferPtr = 0

If Which = "C" Then

AddCombination PopSize, SetSize

Else

AddPermutation PopSize, SetSize

End If

vAllItems = 0

Results.Columns(1).AutoFit

Application.ScreenUpdating = True

Exit Sub

DataError:

If n = 0 Then

Which = "A1 cell must contain the letter C or P, " _

& "A2 is the Number of items in a subset, the cells " _

& "in the third row are the values from Which" _

& "the subset is to be chosen."

Else

Which = "This requires " & Format$(n, "#,##0") & _

" cells, more than are available on the worksheet!"

End If

MsgBox Which, vbOKOnly, "DATA ERROR"

Exit Sub

End Sub

'--------->>

Private Sub AddPermutation(Optional PopSize As Long = 0, _

Optional SetSize As Long = 0, _

Optional NextMember As Long = 0)

Static iPopSize As Long

Static iSetSize As Long

Static SetMembers() As Long

Static Used() As Long

Dim i As Long

If PopSize <> 0 Then

iPopSize = PopSize

iSetSize = SetSize

ReDim SetMembers(1 To iSetSize) As Long

ReDim Used(1 To iPopSize) As Long

NextMember = 1

End If

For i = 1 To iPopSize

If Used(i) = 0 Then

SetMembers(NextMember) = i

If NextMember <> iSetSize Then

Used(i) = True

AddPermutation , , NextMember + 1

Used(i) = False

Else

SavePermutation SetMembers()

End If

Next i

If NextMember = 1 Then

SavePermutation SetMembers(), True

Erase SetMembers

Erase Used

End If

End Sub 'AddPermutation

'--------->>

Private Sub AddCombination(Optional PopSize As Long = 0, _

Optional SetSize As Long = 0, _

Optional NextMember As Long = 0, _

Optional NextItem As Long = 0)

Static iPopSize As Long

Static iSetSize As Long

Static SetMembers() As Long

Dim i As Long

If PopSize <> 0 Then

iPopSize = PopSize

iSetSize = SetSize

ReDim SetMembers(1 To iSetSize) As Long

NextMember = 1

NextItem = 1

End If

For i = NextItem To iPopSize

SetMembers(NextMember) = i

If NextMember <> iSetSize Then

AddCombination , , NextMember + 1, i + 1

Else

SavePermutation SetMembers()

End If

Next i

If NextMember = 1 Then

SavePermutation SetMembers(), True

Erase SetMembers

End If

End Sub 'AddCombination

'--------->>

Private Sub SavePermutation(ItemsChosen() As Long, _

Optional FlushBuffer As Boolean = False)

Dim i As Long, sValue As String

Static RowNum As Long, ColNum As Long

If RowNum = 0 Then RowNum = 1

If ColNum = 0 Then ColNum = 1

If FlushBuffer = True Or BufferPtr = UBound(Buffer()) Then

If BufferPtr > 0 Then

If (RowNum + BufferPtr - 1) > Rows.Count Then

RowNum = 1

ColNum = ColNum + 1

If ColNum > 256 Then Exit Sub

End If

Results.Cells(RowNum, ColNum).Resize(BufferPtr, 1).Value _

= Application.WorksheetFunction.Transpose(Buffer())

RowNum = RowNum + BufferPtr

End If

BufferPtr = 0

If FlushBuffer = True Then

Erase Buffer

RowNum = 0

ColNum = 0

Exit Sub

Else

ReDim Buffer(1 To UBound(Buffer))

End If

'construct the next set

For i = 1 To UBound(ItemsChosen)

sValue = sValue & ", " & vAllItems(ItemsChosen(i), 1)

Next i

'and save it in the buffer

BufferPtr = BufferPtr + 1

Buffer(BufferPtr) = Mid$(sValue, 3)

End Sub 'SavePermutation

'<<=========

Alt+Q per chiudere l'editor di VBA e tornare a Excel
Salva il file con l’estensione xlsm
Alt+F8 per aprire la finestra di gestione delle macro
Seleziona ListPermutationsOrCombinations
Esegui

Un elenco delle 70 combinazioni ordinate sarà creato su un nuovo foglio inserito nel file.

Potresti modificare sia il numero di elementi elencati nella riga 3 del Foglio1, sia il numero di elementi da prendere che è indicato nella cella A2. Se desideri elencare le permutazioni invece delle combinazioni, modifica il valore della cella A1 da C a P.

===

Regards,

Norman

0 commenti

2 risposte aggiuntive

Answer 1

Anonimo

Ciao Gabriele,

Grazie mille Norman per la tua risposta. Ho risolto il rompicapo seguendo le tue istruzioni passo passo. Grazie ancora e complimenti per l'ottimo lavoro!

Mi fa piacere che tu abbia risolto il problema e ti ringrazio per il cortese riscontro.

===

Regards,

Norman

0 commenti

Answer 2

Anonimo

Grazie mille Norman per la tua risposta. Ho risolto il rompicapo seguendo le tue istruzioni passo passo. Grazie ancora e complimenti per l'ottimo lavoro!

0 commenti