PureBasic

Code : Tout sélectionner

Dim Prd As Integer, Niv As Integer
Dim Lg As Integer, NbCols As Integer
Dim NbLignes As Long
Dim Arr(), Cbt, MaxCbt
Dim Max As Long, NbCbt As Long

Sub Combirecherche()
  
  Dim Plage, Dest, P As Range
  Dim Prof, Combins, I As Long
  
  With Application
    Set Plage = .InputBox("Plage de recherche", Type:=8)
    If VarType(Plage) = vbBoolean Then Exit Sub
    Prof = .InputBox("Nombre d'éléments", Type:=1)
    If VarType(Prof) = vbBoolean Then Exit Sub
    Set Dest = .InputBox("Destination", Type:=8)
    If VarType(Dest) = vbBoolean Then Exit Sub
    Combins = CBS(Range(Plage.Address(External:=True)), CInt(Prof))
    .ScreenUpdating = False
  End With
  
  Dest.CurrentRegion.ClearContents
  For Each P In Dest.Resize(UBound(Combins), Prof).Rows
    I = I + 1
    P = Combins(I)
  Next P

End Sub
;--------------------------------------------------------
Function CBS(Plage As Range, Nombre As Integer)

  Dim I As Long
  
  NbLignes = Plage.Rows.Count
  Redim Arr(1 To NbLignes)
  For I = 1 To NbLignes
    Arr(I) = Plage.Rows(I)
  Next I
  Prd = Nombre
  Lg = Plage.Columns.Count
  Niv = 0: Max = 0: NbCbt = 0
  Redim Cbt(1 To Prd)
  Redim MaxCbt(1 To 1)
  For I = 1 To UBound(Arr)
    Recurse I, 1
  Next I
  Application.StatusBar = False
  CBS = MaxCbt

End Function
;--------------------------------------------------------
Private Sub Recurse(L As Long, ByVal Cpt As Integer)
  
  Dim I As Integer
  Static Ligne As Long, C As Integer
  Static Nb As Long, T As Long
  
  On Error Resume Next
  Niv = Niv + 1
  For I = Cpt To Lg
    Cbt(Niv) = Arr(L)(1, I)
    If Niv = Prd Then
      Nb = 1
      For Ligne = L + 1 To NbLignes
        For C = 1 To Prd
          T = Application.Match(Cbt(C), Arr(Ligne), 0)
          If Err Then Err.Clear: Exit For
        Next C
        If C > Prd Then Nb = Nb + 1
      Next Ligne
      If Nb >= Max Then
        If Nb = Max Then
          NbCbt = NbCbt + 1
          Redim Preserve MaxCbt(1 To NbCbt)
        Else
          NbCbt = 1
          Redim MaxCbt(1 To 1)
        End If
        MaxCbt(NbCbt) = Cbt
        Application.StatusBar = NbCbt & " combinaison(s) à " _
          & Max & " occurences (" & Format$(L / NbLignes, "0.0%") & ")"
        Max = Nb
      End If
    Else: Recurse L, I + 1
    End If
  Next I
  Niv = Niv - 1

End Sub
;--------------------------------------------------------