Supprimer lien source macro

Option Explicit
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet

Sub ListPermutations()
Const BufferSize As Long = 4096
Dim Rng As Range, PopSize As Integer
Dim N As Double, SetSize As Integer, Which As String
Set Rng = Selection.Columns(1).Cells
If Rng.Cells.Count = 1 Then Set Rng = Range(Rng, Rng.End(xlDown))
PopSize = Rng.Cells.[B][SIZE="4"]CountLarge[/SIZE][/B] - 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.[B]CountLarge[/B] 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"
End Sub

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

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

Sub SavePermutation(ItemsChosen%(), 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