Lettrage automatique

job75 à dit:

Bonjour le fil, le forum,

Voici une tout autre méthode qui étudie toutes les combinaisons jusqu'à un maximum de 5 débits :

Code:

Sub Rapprochement()
'permet de rapprocher jusqu'à 5 débits
Dim durée#, P As Range, debit, credit, lettrage
Dim i&, cred As Single, a&, n&, b&, c&, d&, e&, f&
durée = Timer
Set P = ActiveSheet.UsedRange
P.Sort ActiveSheet.[A1], xlAscending, Header:=xlYes 'tri par dates
debit = P.Columns("E") 'matrice, plus rapide
credit = P.Columns("F")
P.Columns("H").Offset(1) = "" 'RAZ
lettrage = P.Columns("H")
For i = 2 To P.Rows.Count
  If credit(i, 1) > 0 Then
    cred = credit(i, 1)
    '---1 débit---
    For a = 2 To i - 1
      If lettrage(a, 1) = 1 Then GoTo 2
      If CSng(debit(a, 1)) <> cred Then GoTo 2
      n = n + 1
      lettrage(i, 1) = 1
      lettrage(a, 1) = 1
      P(i, "H") = n
      P(a, "H") = n
      GoTo 1
2   Next a
    '---2 débits---
    For a = 2 To i - 2
      If lettrage(a, 1) = 1 Then GoTo 3
      For b = a + 1 To i - 1
        If lettrage(b, 1) = 1 Then GoTo 4
        If CSng(debit(a, 1) + debit(b, 1)) <> cred Then GoTo 4
        n = n + 1
        lettrage(i, 1) = 1
        lettrage(a, 1) = 1
        lettrage(b, 1) = 1
        P(i, "H") = n
        P(a, "H") = n
        P(b, "H") = n
        GoTo 1
4     Next b
3   Next a
    '---3 débits---
    For a = 2 To i - 3
      If lettrage(a, 1) = 1 Then GoTo 5
      For b = a + 1 To i - 2
        If lettrage(b, 1) = 1 Then GoTo 6
        For c = b + 1 To i - 1
          If lettrage(c, 1) = 1 Then GoTo 7
          If CSng(debit(a, 1) + debit(b, 1) + _
            debit(c, 1)) <> cred Then GoTo 7
          n = n + 1
          lettrage(i, 1) = 1
          lettrage(a, 1) = 1
          lettrage(b, 1) = 1
          lettrage(c, 1) = 1
          P(i, "H") = n
          P(a, "H") = n
          P(b, "H") = n
          P(c, "H") = n
          GoTo 1
7       Next c
6     Next b
5   Next a
    '---4 débits---
    For a = 2 To i - 4
      If lettrage(a, 1) = 1 Then GoTo 8
      For b = a + 1 To i - 3
        If lettrage(b, 1) = 1 Then GoTo 9
        For c = b + 1 To i - 2
          If lettrage(c, 1) = 1 Then GoTo 10
          For d = c + 1 To i - 1
            If lettrage(d, 1) = 1 Then GoTo 11
            If CSng(debit(a, 1) + debit(b, 1) + _
              debit(c, 1) + debit(d, 1)) <> cred Then GoTo 11
            n = n + 1
            lettrage(i, 1) = 1
            lettrage(a, 1) = 1
            lettrage(b, 1) = 1
            lettrage(c, 1) = 1
            lettrage(d, 1) = 1
            P(i, "H") = n
            P(a, "H") = n
            P(b, "H") = n
            P(c, "H") = n
            P(d, "H") = n
            GoTo 1
11        Next d
10      Next c
9     Next b
8   Next a
    '---5 débits---
    For a = 2 To i - 5
      If lettrage(a, 1) = 1 Then GoTo 12
      For b = a + 1 To i - 4
        If lettrage(b, 1) = 1 Then GoTo 13
        For c = b + 1 To i - 3
          If lettrage(c, 1) = 1 Then GoTo 14
          For d = c + 1 To i - 2
            If lettrage(d, 1) = 1 Then GoTo 15
            For e = d + 1 To i - 1
              If lettrage(e, 1) = 1 Then GoTo 16
              If CSng(debit(a, 1) + debit(b, 1) + _
                debit(c, 1) + debit(d, 1) + _
                  debit(e, 1)) <> cred Then GoTo 16
              n = n + 1
              lettrage(i, 1) = 1
              lettrage(a, 1) = 1
              lettrage(b, 1) = 1
              lettrage(c, 1) = 1
              lettrage(d, 1) = 1
              lettrage(e, 1) = 1
              P(i, "H") = n
              P(a, "H") = n
              P(b, "H") = n
              P(c, "H") = n
              P(d, "H") = n
              P(e, "H") = n
              GoTo 1
16          Next e
15        Next d
14      Next c
13    Next b
12  Next a
    lettrage(i, 1) = 1
    P(i, "H") = "Pas trouvé"
    DoEvents 'pour l'affichage
  End If
1 Next i
MsgBox "Durée " & Format(Timer - durée, "0.0 \s")
End Sub

25 crédits ne sont pas trouvés, bien sûr maintenant F27 est trouvé...

Fichier joint.

A+

Cliquez pour agrandir...