Voila le code suivant sur VBA Excel.
On choisis une plage de valeurs ( Plage de recherche / style A1:J100 ) ensuite le ( Nombre d'éléments / Style 4 ) de Combinaisons, ensuite une zone degagé pour ecrire les resultats (Destination / style M1) et au bout d'un certain temps on à le resultat, ( po trop rapide le vba sur ce truc la) .
Ma question , est' il possible de transcrire cela en PureBasic et que cela fonctionne sur excel .
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
;--------------------------------------------------------
