Option Explicit
Const pSN0$ = "à rapprocher"
Const pSN1$ = "Bque"
Const pPMin& = 0 'profondeur minimum de recherche (minimum de jours d'écarts entre dates à rapprocher)
Const pPMax& = 4 'profondeur maximum ...
Sub Test()
Dim Tb0(), Tb1(), Ta0$(), Ta1$(), Ts$(), Tc&(), Tt$(), w(1) As Worksheet, r&(1)
Dim i&, j&, c&, b As Boolean, m#, u&, d As Date, k&, s&, ii&, jj&, n#, t$, kk&, SB$, h&
SB = Application.StatusBar
'définitions
Set w(0) = Worksheets(pSN0)
Set w(1) = Worksheets(pSN1)
'mesures
For i = 0 To 1: r(i) = w(i).Cells(Rows.Count, 1).End(xlUp).Row: Next i
'enregistrement données
ReDim Tb0(2 To r(0), 1 To 5)
For i = 2 To r(0): For j = 1 To 4: Tb0(i, j) = w(0).Cells(i, j): Next j: Next i
ReDim Tb1(2 To r(1), 1 To 4)
For i = 2 To r(1): For j = 1 To 3: Tb1(i, j) = w(1).Cells(i, j): Next j: Next i
'liste antennes
ReDim Ta0(0)
For i = 2 To r(0)
For j = 1 To c
b = (Tb0(i, 4) = Ta0(j))
If b Then Exit For
Next j
If Not b Then
c = c + 1
ReDim Preserve Ta0(c)
Ta0(c) = Tb0(i, 4)
End If
Next i
u = c
'traitement
For i = r(1) To 2 Step -1 'par montant à identifier
Application.StatusBar = "En cours : ligne " & (r(1) - i + 1) & " sur " & (r(1) - 1): DoEvents
m = Tb1(i, 3) 'montant en banque
d = Tb1(i, 1) 'date correspondante
ReDim Ta1(1 To u) 'index lignes par antennes
For j = r(0) To 2 Step -1 'par lignes à rapprocher
If d - Tb0(j, 1) > pPMin - 1 And d - Tb0(j, 1) < pPMax + 1 Then 'compatibilité dates
For k = 1 To u 'par antennes
If Ta0(k) = Tb0(j, 4) Then Ta1(k) = Ta1(k) & ";" & j: Exit For 'enregistrement des lignes
Next k
End If
Next j
For j = 1 To u 'par antennes
If Ta1(j) <> "" Then
Ta1(j) = Right(Ta1(j), Len(Ta1(j)) - 1) 'normalisation
Ts = Split(Ta1(j), ";") 'récupération lignes possibles
s = UBound(Ts) + 1 'nombre
For k = 1 To s 'pour chaque nombre
Tc = CmbTab(s, k) 'combinaisons possibles
For ii = 1 To UBound(Tc) 'par combinaison
n = 0 'montant calculé
t = "" 'texte n° de factures
For jj = 1 To k 'calculs et écritures
n = n + Tb0(Ts(Tc(ii, jj) - 1), 3)
t = t & "+" & Tb0(Ts(Tc(ii, jj) - 1), 2)
If Not Round(n, 2) < Round(m, 2) Then Exit For 'test sortie
Next jj
If Round(n, 2) = Round(m, 2) Then 'match
t = Right(t, Len(t) - 1)
b = False
If CStr(Tb1(i, 4)) <> "" Then 'test nouvelle possibilité ?
Tt = Split(Tb1(i, 4), ";")
For kk = 0 To UBound(Tt)
b = (t = Tt(kk))
If b Then Exit For
Next kk
Erase Tt
End If
If Not b Then
Tb1(i, 4) = Tb1(i, 4) & ";" & t 'enregistrement n° de factures
For kk = 1 To k
Tt = Split(Tb0(Ts(Tc(ii, kk) - 1), 5), ";")
For h = 0 To UBound(Tt)
b = (d & " " & m = Tt(h))
If b Then Exit For
Next h
If Not b Then Tb0(Ts(Tc(ii, kk) - 1), 5) = Tb0(Ts(Tc(ii, kk) - 1), 5) & ";" & d & " " & m 'enregistrement date paiement et montant global
Next kk
End If
End If
Next ii
Erase Tc
Next k
Erase Ts
End If
Next j
Next i
Erase Ta0: Erase Ta1
'restitution
Application.StatusBar = "En cours : écritures": DoEvents
For i = 2 To r(0)
If CStr(Tb0(i, 5)) <> "" Then
w(0).Cells(i, 5) = Replace(Right(Tb0(i, 5), Len(Tb0(i, 5)) - 1), ";", " ou ")
Else
w(0).Cells(i, 5) = ""
End If
Next i
Erase Tb0
For i = 2 To r(1)
If CStr(Tb1(i, 4)) <> "" Then
w(1).Cells(i, 4) = Replace(Right(Tb1(i, 4), Len(Tb1(i, 4)) - 1), ";", " ou ")
Else
w(1).Cells(i, 4) = ""
End If
Next i
Erase Tb1
Application.StatusBar = SB
End Sub
'----------------------------------------------------------------------------------------------------------------
'combinaisons b parmi a******************************************************************************************
'Input : longs***************************************************************************************************
'Output : tableau long*******************************************************************************************
'Rem : taille max varie selon systèmes, si erreur ubound(t)=0****************************************************
'----------------------------------------------------------------------------------------------------------------
Function CmbTab(ByVal a&, ByVal b&) As Long()
Dim t&(), c&, i&, j&, d As Boolean
If Not a < 1 And Not b < 1 And Not b > a Then
On Error GoTo ErrTrp
ReDim t(1 To CLng(CmbNb(a, b)), 1 To b)
c = a - b
For i = 1 To b: t(1, i) = i: Next i
For i = 2 To UBound(t)
If b = 1 Then t(i, 1) = t(i - 1, 1) - (b = 1) Else t(i, 1) = t(i - 1, 1) + (t(i - 1, 2) = c + 2) * (b <> 1)
For j = 2 To b - 1
If t(i - 1, j + 1) = c + j + 1 Then
d = t(i - 1, j) = c + j
t(i, j) = t(i + (Not d), j + d) + 1
Else
t(i, j) = t(i - 1, j)
End If
Next j
d = t(i - 1, b) = a
t(i, b) = t(i + (Not d), b + d) + 1
Next i
CmbTab = t
Else
ErrTrp:
On Error GoTo 0
ReDim t(0)
CmbTab = t
End If
End Function
'----------------------------------------------------------------------------------------------------------------
'Nombre de combinaisons de b éléments pris parmis a éléments*****************************************************
'Input : a, b****************************************************************************************************
'----------------------------------------------------------------------------------------------------------------
Function CmbNb(ByVal a&, ByVal b&) As Variant
Dim c&
On Error GoTo ErrTrp
If Not a < 0 And Not b < 0 And Not b > a Then
c = a - b
If c = 0 Then
CmbNb = 1
Else
If b < c Then c = b
CmbNb = FactLim(a, c) / FactLim(c)
End If
Else
CmbNb = CVErr(xlErrNum)
End If
Exit Function
ErrTrp:
On Error GoTo 0
CmbNb = CVErr(xlErrNum)
End Function
'----------------------------------------------------------------------------------------------------------------
'Factorielle de Lg***********************************************************************************************
'Option : limiter le nombre d'itérations*************************************************************************
'----------------------------------------------------------------------------------------------------------------
Function FactLim(ByVal Lg&, Optional NbIter) As Variant
Dim i&, n&
On Error GoTo ErrTrp
If Not Lg < 0 Then
If Not IsMissing(NbIter) Then n = CLng(NbIter) Else n = Lg
If n > Lg Or n < 0 Then
GoTo ErrTrp
Else
FactLim = 1
If Lg > 0 Then
For i = 0 To n - 1: FactLim = FactLim * (Lg - i): Next i
End If
End If
Else
FactLim = CVErr(xlErrNA)
End If
Exit Function
ErrTrp:
On Error GoTo 0
FactLim = CVErr(xlErrNum)
End Function
