Ciao Nelson,
Vorrei ricavare una tabella con il calcolo combinatorio di 24 numeri, raggruppati in 6 elementi per ogni riga.
Dovrebbero risultare alla fine, 134.596 righe da 6 numeri ciascuna.
Indicatemi per favore dove scrivere i 24 numeri, affinche' dopo l' elaborazione, possa rendermi conto se il risultato e' cio' che mi aspetto oppure no.
| 1 |
| 7 |
| 11 |
| 13 |
| 17 |
| 19 |
| 23 |
| 29 |
| 31 |
| 37 |
| 41 |
| 43 |
| 47 |
| 49 |
| 53 |
| 59 |
| 61 |
| 67 |
| 71 |
| 73 |
| 77 |
| 79 |
| 83 |
| 89 |
Dovrebbe cosi' iniziare con la 1° sestina = 1.7.11.13.17.19 e dovrebbe concludersi con : 71.73.77.79.83.89
Prova qualcosa del genere:
- Alt+F11 per aprire l'editor di VBA
- Alt+IM per 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
'--------->>
Public Sub ListPermutations()
'\ Adattamento del codice di Myrna Larson (25/7/2000):
'\ http://tinyurl.com/l7w6p
Dim WB As Workbook
Dim SH As Worksheet
Dim Rng As Range
Dim iLastRow As Long
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 SH = WB.Sheets("Foglio1") '<<=== Modifica
iLastRow = SH.Cells(Rows.Count, "A").End(xlUp).Row
Set Rng = SH.Range("A1:A" & iLastRow)
PopSize = Rng.Cells.Count - 2
If PopSize < 2 Then GoTo DataError
SetSize = Rng.Cells(2).Value
If SetSize > PopSize Then GoTo DataError
Which = UCase$(Rng.Cells(1).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
Set Results = Worksheets.Add
vAllItems = Rng.Offset(2, 0).Resize(PopSize).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
Application.ScreenUpdating = True
Exit Sub
DataError:
If N = 0 Then
Which = "Enter your data in a vertical range of at least 4 cells. " _
& String$(2, 10) _
& "Top cell must contain the letter C or P, 2nd cell is the number " _
& "of items in a subset, the cells below 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
End If
Next i
If NextMember = 1 Then
SavePermutation SetMembers(), True
Erase SetMembers
Erase Used
End If
End Sub
'--------->>
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
'--------->>
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
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
'<<=========
- 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
- Nella cella A1 del Foglio1, C (per combinazioni)
- Nella cella A2, inserisci 6 (il numero di elementi da utilizzare in ogni combinazione)
- Nelle celle A3:A26 immetti i numer da combinare
- Seleziona Tester | Esegui
Se non hai familiarità con le macro, ti consiglio il seguente articolo eccellente di Mauro:
http://answers.microsoft.com/it-it/office/wiki/office\_2013\_release-excel/excel-dove-e-come-inserire-il-codice-visual-basic/ed29ee63-a537-4e5d-8631-76766cf40503
Potresti scaricare il mio file di prova Nelson20160224.xlsm a:
https://www.dropbox.com/s/t2f993fgo3545o7/Nelson20160224.xlsm?dl=0
===
Regards,
Norman
![](data:image/svg+xml, %3Csvg xmlns='http://www.w3.org/2000/svg' height='64' class='font-weight-bold' style='font: 600 30.11764705882353px "SegoeUI", Arial' width='64'%3E%3Ccircle fill='hsl(128, 8%, 22%)' cx='32' cy='32' r='32' /%3E%3Ctext x='50%25' y='55%25' dominant-baseline='middle' text-anchor='middle' fill='%23FFF' %3EA%3C/text%3E%3C/svg%3E)
