Option Explicit
 
 'Written by Myrna Larson - Microsoft Excel MVP
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
 
 
Sub ListPermutations()
    Dim Rng As Range
    Dim PopSize As Integer
    Dim SetSize As Integer
    Dim Which As String
    Dim N As Double
    Const BufferSize As Long = 4096
     
     
    Set Rng = Range(Range("A1"), Cells(Rows.Count, "A").End(xlUp))
     
    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 > Cells.CountLarge 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 Integer = 0, _
    Optional SetSize As Integer = 0, _
    Optional NextMember As Integer = 0)
     
    Static iPopSize As Integer
    Static iSetSize As Integer
    Static SetMembers() As Integer
    Static Used() As Integer
    Dim i As Integer
     
    If PopSize <> 0 Then
        iPopSize = PopSize
        iSetSize = SetSize
        ReDim SetMembers(1 To iSetSize) As Integer
        ReDim Used(1 To iPopSize) As Integer
        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 'AddPermutation
 
Private Sub AddCombination(Optional PopSize As Integer = 0, _
    Optional SetSize As Integer = 0, _
    Optional NextMember As Integer = 0, _
    Optional NextItem As Integer = 0)
     
    Static iPopSize As Integer
    Static iSetSize As Integer
    Static SetMembers() As Integer
    Dim i As Integer
     
    If PopSize <> 0 Then
        iPopSize = PopSize
        iSetSize = SetSize
        ReDim SetMembers(1 To iSetSize) As Integer
        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 Integer, _
    Optional FlushBuffer As Boolean = False)
     
    Dim i As Integer, 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 'SavePermutation

Option Explicit

Sub ABBINAMENTI()
Dim Nomi As Range
Dim i As Long, o As Long, Nriga As Long
Dim noMe As Variant
Nriga = 1
Range("M1:M100,F1:F1000").ClearContents
Set Nomi = Selection
 For Each noMe In Nomi
   Cells(Nriga, "M") = noMe
   Nriga = Nriga + 1
 Next
 Nriga = 1
For i = 1 To Cells(Rows.Count, "M").End(xlUp).Row
 noMe = Cells(i, "M")
For o = i + 1 To Cells(Rows.Count, "M").End(xlUp).Row
  Cells(Nriga, "F") = noMe & " " & Cells(o, "M")
  Nriga = Nriga + 1
Next o
Next i
Set Nomi = Nothing
End Sub