Ciao
Credo che quello che chiedi lo fa la macro seguente ma con alcune precisazioni:
cella scrivi
in C1 lettere
in C2 classe
in C3 lett.scelta
in C4 elenco combinazioni che includono la lettera scelta
intervallo D1:M1 le lettere da combinare.
Importante:
in D2 il numero di "sestine" (come le chiami tu ma puoi indicare un numero compreso tra 2 e 10)
in D3 la lettera da te scelta.
Option Explicit
Sub ProvaComb()
Dim nElem As Integer, nClas As Integer, sLett As String, DimGroup As Integer
Dim i As Long, CombS, r As Long, testo As String, flag As Integer, x As Integer
Dim arrayElementi() As Variant, cn As Long
nClas = Range("D2").Value
sLett = Range("D3").Value
For i = 0 To Cells(1, Columns.Count).End(xlToLeft).Column - 1
If IsEmpty(Cells(1, i + 4)) Then Exit For
ReDim Preserve arrayElementi(0 To i)
arrayElementi(i) = Cells(1, i + 4).Value
nElem = nElem + 1
Next i
Range("D5:M100000").ClearContents
If nElem = 0 Or nClas = 0 Or nClas > nElem Then Exit Sub
DimGroup = nClas
Dim LC As New Collection
If UBound(arrayElementi) = 0 Then
Set CombS = LC
End If
If DimGroup = 0 Or DimGroup > UBound(arrayElementi) Then
Set CombS = LC
End If
Dim aP() As Integer
ReDim aP(DimGroup - 1)
Dim k As Integer
For k = 0 To UBound(aP)
aP(k) = k
Next k
Dim j As Integer
Dim c As String
Dim cnt As Integer
Do
c = ""
For i = 0 To UBound(aP)
c = c & arrayElementi(aP(i))
Next i
LC.Add (c)
cnt = 0
For i = UBound(aP) To 0 Step -1
If aP(i) = UBound(arrayElementi) - cnt Then
cnt = cnt + 1
If cnt = UBound(aP) + 1 Then Exit Do
Else
aP(i) = aP(i) + 1
For j = 0 To UBound(aP)
If i < j Then aP(j) = aP(i) + (j - i)
Next
Exit For
End If
Next i
Loop
Set CombS = LC
r = 4
For i = 1 To LC.Count
testo = LC(i)
flag = 0
For x = 1 To Len(testo)
If Mid(testo, x, 1) = sLett Then flag = 1
Next x
If flag = 1 Then
cn = 4
r = r + 1
For j = 1 To Len(testo)
Cells(r, cn) = Mid(testo, j, 1)
cn = cn + 1
Next j
testo = ""
End If
Next i
Set CombS = Nothing
Cells(1, 1).Select
End Sub
E' un po' lunga ma fa il suo dovere.
Fai sapere. Ciao,
Mario