automatisation Rapprochement bancaire

**Novice excel vba** · 24/06/2021, 11h19

Bonjour à tous,

je souhaiterai mettre en place une macro sur un rapprochement bancaire

Je dois rapprocher débit/crédit (les montants) mais avec la colonne Description 2 qui corresponds au libellé.

dans certains cas, il peut avoir par exemple un débit d'un montant de 1000€ et plusieurs montant de crédit.

Voila, pourquoi je voudrais rapprocher avec le libellée qui correspond la colonne Description 2.

Je vous envoi mon fichier qui correspond à une requête BO en format Excel

Je vous remercie d'avance de votre aide

**Novice excel vba** · 01/07/2021, 16h55

Bonjour tout le monde,

J'ai avancé sur le sujet grâce à un expert, il me manque juste un élément sur ma macro c'est de rajouter la date.

Je m'explique, dans l'onglet résultat, nous avons 2 colonnes.

La 1er c'est la colonne "description 2" qui rassemble les débits et crédits qui sont sur la colonne 2, ça me permet de voir ceux qui sont pas à zéro (non rapprochés) .

Maintenant je veux avoir les dates comptable qui me permettent de savoir quand les écritures non rapprochés (débit crédit) supérieur à zéro sont à quelles dates.

Les conditions sont les écritures comptables qui sont non rapprochées qu'ont puissent voir aussi les dates comptables qui me permettent de faire une recherche sur les suspens comptables.

Je sais pas si je suis clair.

Bonne soirée !

**ARTURO83** · 04/07/2021, 08h10

Bonjour,

Un écart entre crédit et débit peut être dû à plusieurs débits non crédités donc, il faut rechercher tous les débits qui n'ont pas été crédités et qui génère cet écart par rapport à un crédit unique.
Dans la proposition que voici, on trouve 2 fois ce cas de figure, lignes 236 et 255, pour ces cas, dans la cellule de la date, je mets le montant de chaque débit trouvé avec la date correspondante.

Pièce jointe 601051

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
 Option Explicit
 
 Sub Recup_Debit()
    Dim DerLig_f1 As Long, DerLig_f2 As Long, Nb_x As Long, Nb_Code As Long, J As Long, i As Long
    Dim Total_Debit As Double, Ecart As Double
    Dim Debit As String, Deb As String, Code As String
    Dim d As Object, c As Object
    Dim f1 As Worksheet, f2 As Worksheet
    Application.ScreenUpdating = False
    Set f1 = Sheets("Interrogation des écritures")
    Set f2 = Sheets("Resultat")
    f1.AutoFilterMode = False
    DerLig_f1 = f1.Range("A" & Rows.Count).End(xlUp).Row
    f1.Range(f1.Cells(17, "D"), f1.Cells(DerLig_f1, "G")).UnMerge 'Suppression des cellules fusionnées
    f1.Range("A19:O" & DerLig_f1).Sort f1.Range("H18"), 2
 
    f2.Select
    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
    f2.AutoFilterMode = False
 
    If DerLig_f2 > 1 Then Range(f2.Cells(2, "A"), f2.Cells(DerLig_f2, "C")).ClearContents
    f1.Range(f1.Range("M19"), f1.Range("M19").End(xlDown)).Copy f2.Range("A2")
    f2.Range("A1:A" & DerLig_f1).RemoveDuplicates Columns:=1, Header:=xlNo
    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
    f2.Range("B2:B" & DerLig_f2).FormulaR1C1 = "=round(SUMIF('" & f1.Name & "'!R19C13:R" & DerLig_f1 & "C13,RC1,'" & f1.Name & "'!R19C11:R" & DerLig_f1 & "C11)-SUMIF('" & f1.Name & "'!R19C13:R" & DerLig_f1 & "C13,RC1,'" & f1.Name & "'!R19C12:R" & DerLig_f1 & "C12),2)"
    f2.Range("B2:B" & DerLig_f2).Value = f2.Range("B2:B" & DerLig_f2).Value
    f2.Range("A1:B" & DerLig_f1 - 17).AutoFilter Field:=2, Criteria1:="0.00"
    f2.Rows("2:" & DerLig_f1 - 17).SpecialCells(xlCellTypeVisible).Delete
    f2.AutoFilterMode = False
    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
 
    f2.Range("C2").FormulaArray = "=IFERROR(INDEX('" & f1.Name & "'!R18C2:R" & DerLig_f1 & "C15,MATCH(1,('" & f1.Name & "'!R18C13:R" & DerLig_f1 & "C13=RC1)*('" & f1.Name & "'!R18C11:R" & DerLig_f1 & "C11=RC2),0),7),""X"")"
    f2.Range("C2").AutoFill Destination:=f2.Range("C2:C" & DerLig_f2)
    f2.Range("C2:C" & DerLig_f2).Value = f2.Range("C2:C" & DerLig_f2).Value
 
    'Recherche de dates non conformes liées à un débit constitué de plusieurs valeurs
    Nb_x = Application.CountIf(f2.Range("C2:C" & DerLig_f2), "X")
    If Nb_x <> 0 Then
        ActiveWorkbook.Worksheets(f1.Name).Sort.SortFields.Clear
        ActiveWorkbook.Worksheets(f1.Name).Sort.SortFields.Add Key:=f1.Range("M19:M" & DerLig_f1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        ActiveWorkbook.Worksheets(f1.Name).Sort.SortFields.Add Key:=f1.Range("H19:H" & DerLig_f1), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets(f1.Name).Sort
            .SetRange f1.Range("H18:O" & DerLig_f1)
            .Header = xlYes
            .Apply
        End With
Suivant:
        Total_Debit = 0
        Debit = ""
        With f2.Range("C1:C" & DerLig_f2)
            Set d = .Find("X", lookat:=xlWhole)
            If Not d Is Nothing Then
                Deb = d.Address
                Code = f2.Cells(d.Row, "A")
                Ecart = f2.Cells(d.Row, "B")
                Nb_Code = Application.CountIf(f1.Range("M19:M" & DerLig_f1), Code)
                With f1.Range("M19:M" & DerLig_f1)
                    Set c = .Find(Code, lookat:=xlWhole)
                    J = c.Row + Nb_Code - 1 'Ligne la plus basse du code cherché
                    For i = c.Row + Nb_Code - 2 To c.Row - 1 Step -1
                        If f1.Cells(i, "K") <> f1.Cells(J, "L") And f1.Cells(i, "K") <> 0 Then
                            Total_Debit = Total_Debit + f1.Cells(i, "K")
                            If Round(Total_Debit - f1.Cells(J, "L"), 2) <> Round(Ecart, 2) Then
                                Debit = Debit & Chr(10) & f1.Cells(i, "K") & ": " & f1.Cells(i, "H")
                            Else
                                Debit = Debit & Chr(10) & f1.Cells(i, "K") & ": " & f1.Cells(i, "H")
                                f2.Cells(d.Row, "C") = Right(Debit, Len(Debit) - 1)
                                GoTo Suivant
                            End If
                        Else
                            If f1.Cells(i, "K") <> 0 Then J = J - 2
                        End If
                    Next i
                End With
            End If
        End With
    End If
 
    MsgBox "Traitement terminé"
    Set f1 = Nothing
    Set f2 = Nothing
End Sub
 
Sub effacer()
    Dim DerLig_f2 As Long
    Dim f2 As Worksheet
    Application.ScreenUpdating = False
    Set f2 = Sheets("Resultat")
    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
    If DerLig_f2 > 1 Then Range(f2.Cells(2, "A"), f2.Cells(DerLig_f2, "C")).ClearContents
    Set f2 = Nothing
End Sub

Cdlt

**Pierre Fauconnier** · 05/07/2021, 07h30

Salut

Perso, voilà comment je travaillerais:

Préparation des données en tableau structuré;
Power Query pour créer la table des "description 2" non balancés;
Power Query pour créer la table des mouvements non balancés par "description 2".

Ca t'éviterait le vba vu que tu n'es pas programmeur. Pourrais-tu préciser ta version d'Excel?

**Novice excel vba** · 06/07/2021, 13h56

Envoyé par ARTURO83

Bonjour,

Je te remercie de ta réponse, je viens juste de la voir...

j'aime beaucoup ton résultat, le souci j'ai relancé la macro et j'ai un souci sur cette ligne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

f2.Rows("2:" & DerLig_f1 - 17).SpecialCells(xlCellTypeVisible).Delete

Comment résoudre le problème ?

Cordialement,

Envoyé par Pierre Fauconnier

Bonjour,

Je te remercie de ta réponse

Au travail, j'ai une version Excel 2016 pro

**Pierre Fauconnier** · 06/07/2021, 14h18

Pourrais-tu, sur base d'un tableau de quelques lignes, montrer le résultat que tu souhaites obtenir?

**Novice excel vba** · 06/07/2021, 14h31

Je souhaiterai mettre en place un rapprochement bancaire automatique

Je dois rapprocher débit/crédit (les montants) mais avec la colonne Description 2 qui corresponds au libellé.

Dans certains cas, il peut avoir par exemple un débit d'un montant de 1000€ et plusieurs montant de crédit et vis versa .

Voila, pourquoi je voudrais rapprocher avec le libellée qui correspond la colonne Description 2.

Je vous envoi mon fichier qui correspond à une requête BO en format Excel sur le 1er onglet et sur le 2eme onglet, je voudrais apparaitre que les non rapprochées (les suspens bancaires) avec 3 colonnes (la date comptable, la Description 2 et le montant).

Je vous remercie d'avance de votre aide!

Envoyé par Pierre Fauconnier

Pourrais-tu, sur base d'un tableau de quelques lignes, montrer le résultat que tu souhaites obtenir?

**Novice excel vba** · 09/07/2021, 10h27

Envoyé par ARTURO83

Bonjour,

Un écart entre crédit et débit peut être dû à plusieurs débits non crédités donc, il faut rechercher tous les débits qui n'ont pas été crédités et qui génère cet écart par rapport à un crédit unique.
Dans la proposition que voici, on trouve 2 fois ce cas de figure, lignes 236 et 255, pour ces cas, dans la cellule de la date, je mets le montant de chaque débit trouvé avec la date correspondante.

Pièce jointe 601051

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
 Option Explicit
 
 Sub Recup_Debit()
    Dim DerLig_f1 As Long, DerLig_f2 As Long, Nb_x As Long, Nb_Code As Long, J As Long, i As Long
    Dim Total_Debit As Double, Ecart As Double
    Dim Debit As String, Deb As String, Code As String
    Dim d As Object, c As Object
    Dim f1 As Worksheet, f2 As Worksheet
    Application.ScreenUpdating = False
    Set f1 = Sheets("Interrogation des écritures")
    Set f2 = Sheets("Resultat")
    f1.AutoFilterMode = False
    DerLig_f1 = f1.Range("A" & Rows.Count).End(xlUp).Row
    f1.Range(f1.Cells(17, "D"), f1.Cells(DerLig_f1, "G")).UnMerge 'Suppression des cellules fusionnées
    f1.Range("A19:O" & DerLig_f1).Sort f1.Range("H18"), 2
 
    f2.Select
    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
    f2.AutoFilterMode = False
 
    If DerLig_f2 > 1 Then Range(f2.Cells(2, "A"), f2.Cells(DerLig_f2, "C")).ClearContents
    f1.Range(f1.Range("M19"), f1.Range("M19").End(xlDown)).Copy f2.Range("A2")
    f2.Range("A1:A" & DerLig_f1).RemoveDuplicates Columns:=1, Header:=xlNo
    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
    f2.Range("B2:B" & DerLig_f2).FormulaR1C1 = "=round(SUMIF('" & f1.Name & "'!R19C13:R" & DerLig_f1 & "C13,RC1,'" & f1.Name & "'!R19C11:R" & DerLig_f1 & "C11)-SUMIF('" & f1.Name & "'!R19C13:R" & DerLig_f1 & "C13,RC1,'" & f1.Name & "'!R19C12:R" & DerLig_f1 & "C12),2)"
    f2.Range("B2:B" & DerLig_f2).Value = f2.Range("B2:B" & DerLig_f2).Value
    f2.Range("A1:B" & DerLig_f1 - 17).AutoFilter Field:=2, Criteria1:="0.00"
    f2.Rows("2:" & DerLig_f1 - 17).SpecialCells(xlCellTypeVisible).Delete
    f2.AutoFilterMode = False
    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
 
    f2.Range("C2").FormulaArray = "=IFERROR(INDEX('" & f1.Name & "'!R18C2:R" & DerLig_f1 & "C15,MATCH(1,('" & f1.Name & "'!R18C13:R" & DerLig_f1 & "C13=RC1)*('" & f1.Name & "'!R18C11:R" & DerLig_f1 & "C11=RC2),0),7),""X"")"
    f2.Range("C2").AutoFill Destination:=f2.Range("C2:C" & DerLig_f2)
    f2.Range("C2:C" & DerLig_f2).Value = f2.Range("C2:C" & DerLig_f2).Value
 
    'Recherche de dates non conformes liées à un débit constitué de plusieurs valeurs
    Nb_x = Application.CountIf(f2.Range("C2:C" & DerLig_f2), "X")
    If Nb_x <> 0 Then
        ActiveWorkbook.Worksheets(f1.Name).Sort.SortFields.Clear
        ActiveWorkbook.Worksheets(f1.Name).Sort.SortFields.Add Key:=f1.Range("M19:M" & DerLig_f1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        ActiveWorkbook.Worksheets(f1.Name).Sort.SortFields.Add Key:=f1.Range("H19:H" & DerLig_f1), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets(f1.Name).Sort
            .SetRange f1.Range("H18:O" & DerLig_f1)
            .Header = xlYes
            .Apply
        End With
Suivant:
        Total_Debit = 0
        Debit = ""
        With f2.Range("C1:C" & DerLig_f2)
            Set d = .Find("X", lookat:=xlWhole)
            If Not d Is Nothing Then
                Deb = d.Address
                Code = f2.Cells(d.Row, "A")
                Ecart = f2.Cells(d.Row, "B")
                Nb_Code = Application.CountIf(f1.Range("M19:M" & DerLig_f1), Code)
                With f1.Range("M19:M" & DerLig_f1)
                    Set c = .Find(Code, lookat:=xlWhole)
                    J = c.Row + Nb_Code - 1 'Ligne la plus basse du code cherché
                    For i = c.Row + Nb_Code - 2 To c.Row - 1 Step -1
                        If f1.Cells(i, "K") <> f1.Cells(J, "L") And f1.Cells(i, "K") <> 0 Then
                            Total_Debit = Total_Debit + f1.Cells(i, "K")
                            If Round(Total_Debit - f1.Cells(J, "L"), 2) <> Round(Ecart, 2) Then
                                Debit = Debit & Chr(10) & f1.Cells(i, "K") & ": " & f1.Cells(i, "H")
                            Else
                                Debit = Debit & Chr(10) & f1.Cells(i, "K") & ": " & f1.Cells(i, "H")
                                f2.Cells(d.Row, "C") = Right(Debit, Len(Debit) - 1)
                                GoTo Suivant
                            End If
                        Else
                            If f1.Cells(i, "K") <> 0 Then J = J - 2
                        End If
                    Next i
                End With
            End If
        End With
    End If
 
    MsgBox "Traitement terminé"
    Set f1 = Nothing
    Set f2 = Nothing
End Sub
 
Sub effacer()
    Dim DerLig_f2 As Long
    Dim f2 As Worksheet
    Application.ScreenUpdating = False
    Set f2 = Sheets("Resultat")
    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
    If DerLig_f2 > 1 Then Range(f2.Cells(2, "A"), f2.Cells(DerLig_f2, "C")).ClearContents
    Set f2 = Nothing
End Sub

Cdlt

Bonjour tu vas bien?

Je te remercie de ton travail.

j'ai essayé avec un autre compte bancaire, et je constate que sur l'onglet résultat nous avons pas tous les suspens.

je vous donne un exemple sur 2 lignes (lignes 195 et 196 en jaune) I18700510188 et I18700510200 devrait sortir en écart, et hélas c'est pas le cas.

Pouvez-vous voir quelle est l'anomalie sur la macro? Je vous envoi le fichier directement sur la page "automatisation du rapprochement".

Bonne journée

**ARTURO83** · 09/07/2021, 14h37

Bonjour,

Code modifié

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
Option Explicit
 
 Sub Recup_Debit()
    Dim DerLig_f1 As Long, DerLig_f2 As Long, Nb_x As Long, Nb_Code As Long, J As Long, i As Long
    Dim Total_Debit As Double, Ecart As Double
    Dim Debit As String, Credit As String, Deb As String, Code As String
    Dim d As Object, c As Object, z As Object
    Dim f1 As Worksheet, f2 As Worksheet
    Application.ScreenUpdating = False
    Set f1 = Sheets("Interrogation des écritures")
    Set f2 = Sheets("Resultat")
    f1.AutoFilterMode = False
    DerLig_f1 = f1.Range("A" & Rows.Count).End(xlUp).Row
    f1.Range(f1.Cells(17, "D"), f1.Cells(DerLig_f1, "G")).UnMerge
    f1.Range("A19:O" & DerLig_f1).Sort f1.Range("H18"), 2
 
    f2.Select
    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
    f2.AutoFilterMode = False
 
    If DerLig_f2 > 1 Then Range(f2.Cells(2, "A"), f2.Cells(DerLig_f2, "D")).ClearContents
    f1.Range(f1.Range("M19"), f1.Range("M19:M" & DerLig_f1)).Copy f2.Range("A2")
    f2.Range("A1:A" & DerLig_f1).RemoveDuplicates Columns:=1, Header:=xlNo
    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
    f2.Range("B2:B" & DerLig_f2).FormulaR1C1 = "=round(SUMIF('" & f1.Name & "'!R19C13:R" & DerLig_f1 & "C13,RC1,'" & f1.Name & "'!R19C11:R" & DerLig_f1 & "C11)-SUMIF('" & f1.Name & "'!R19C13:R" & DerLig_f1 & "C13,RC1,'" & f1.Name & "'!R19C12:R" & DerLig_f1 & "C12),2)"
    f2.Range("B2:B" & DerLig_f2).Value = f2.Range("B2:B" & DerLig_f2).Value
    f2.AutoFilterMode = False
    'DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
 
    f2.Range("C2").FormulaArray = "=IFERROR(INDEX('" & f1.Name & "'!R18C2:R" & DerLig_f1 & "C15,MATCH(1,('" & f1.Name & "'!R18C13:R" & DerLig_f1 & "C13=RC1)*('" & f1.Name & "'!R18C11:R" & DerLig_f1 & "C11=RC2),0),7),""X"")"
    f2.Range("C2").AutoFill Destination:=f2.Range("C2:C" & DerLig_f2)
    f2.Range("C2:C" & DerLig_f2).Value = f2.Range("C2:C" & DerLig_f2).Value
 
    'Recherche de dates non conformes liées à un débit constitué de plusieurs valeurs
    Nb_x = Application.CountIf(f2.Range("C2:C" & DerLig_f2), "X")
    If Nb_x <> 0 Then
        ActiveWorkbook.Worksheets(f1.Name).Sort.SortFields.Clear
        ActiveWorkbook.Worksheets(f1.Name).Sort.SortFields.Add Key:=f1.Range("M19:M" & DerLig_f1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        ActiveWorkbook.Worksheets(f1.Name).Sort.SortFields.Add Key:=f1.Range("H19:H" & DerLig_f1), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets(f1.Name).Sort
            .SetRange f1.Range("H18:O" & DerLig_f1)
            .Header = xlYes
            .Apply
        End With
Suivant:
        Total_Debit = 0
        Debit = ""
        Credit = ""
        With f2.Range("C1:C" & DerLig_f2)
            Set d = .Find("X", LookAt:=xlWhole)
            If Not d Is Nothing Then
                Deb = d.Address
                Code = f2.Cells(d.Row, "A")
                Ecart = f2.Cells(d.Row, "B")
                Nb_Code = Application.CountIf(f1.Range("M19:M" & DerLig_f1), Code)
                With f1.Range("M19:M" & DerLig_f1)
                    Set c = .Find(Code, LookAt:=xlWhole)
                    J = c.Row + Nb_Code - 1 'Ligne la plus basse du code cherché
                    For i = c.Row + Nb_Code - 2 To c.Row - 1 Step -1
                        If f1.Cells(i, "K") <> f1.Cells(J, "L") And f1.Cells(i, "K") <> 0 Then
                            Total_Debit = Total_Debit + f1.Cells(i, "K")
                            If Credit <> Chr(10) & f1.Cells(J, "L") & ": " & f1.Cells(J, "H") Then Credit = Credit & Chr(10) & f1.Cells(J, "L") & ": " & f1.Cells(J, "H")
                            If Round(Total_Debit - f1.Cells(J, "L"), 2) <> Round(Ecart, 2) Then
                                Debit = Debit & Chr(10) & f1.Cells(i, "K") & ": " & f1.Cells(i, "H")
                            Else
                                Debit = Debit & Chr(10) & f1.Cells(i, "K") & ": " & f1.Cells(i, "H")
                                'If f1.Cells(J, "L") <> 0 Then Credit = Credit & Chr(10) & f1.Cells(J, "L") & ": " & f1.Cells(J, "H")
                                f2.Cells(d.Row, "C") = Right(Debit, Len(Debit) - 1)
                                f2.Cells(d.Row, "D") = Right(Credit, Len(Credit) - 1)
                                GoTo Suivant
                            End If
                        Else
                            If f1.Cells(i, "K") <> 0 Then J = J - 2
                        End If
                    Next i
                End With
            End If
        End With
    End If
 
    'Tri descendant pour mettre les zéros en fon ce tableau
    f2.Range("A2:D" & DerLig_f2).Sort [B1], 2
 
    'Suppression des zéros
    With f2.Range("B1:B" & DerLig_f2)
        Set z = .Find(0, LookAt:=xlWhole)
        If Not z Is Nothing Then Range(f2.Cells(z.Row, "A"), f2.Cells(DerLig_f2, "D")).Delete
    End With
 
    MsgBox "Traitement terminé"
    Set z = Nothing
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Cdlt

**Novice excel vba** · 09/07/2021, 15h16

Envoyé par ARTURO83

Bonjour,

Code modifié

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
Option Explicit
 
 Sub Recup_Debit()
    Dim DerLig_f1 As Long, DerLig_f2 As Long, Nb_x As Long, Nb_Code As Long, J As Long, i As Long
    Dim Total_Debit As Double, Ecart As Double
    Dim Debit As String, Credit As String, Deb As String, Code As String
    Dim d As Object, c As Object, z As Object
    Dim f1 As Worksheet, f2 As Worksheet
    Application.ScreenUpdating = False
    Set f1 = Sheets("Interrogation des écritures")
    Set f2 = Sheets("Resultat")
    f1.AutoFilterMode = False
    DerLig_f1 = f1.Range("A" & Rows.Count).End(xlUp).Row
    f1.Range(f1.Cells(17, "D"), f1.Cells(DerLig_f1, "G")).UnMerge
    f1.Range("A19:O" & DerLig_f1).Sort f1.Range("H18"), 2
 
    f2.Select
    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
    f2.AutoFilterMode = False
 
    If DerLig_f2 > 1 Then Range(f2.Cells(2, "A"), f2.Cells(DerLig_f2, "D")).ClearContents
    f1.Range(f1.Range("M19"), f1.Range("M19:M" & DerLig_f1)).Copy f2.Range("A2")
    f2.Range("A1:A" & DerLig_f1).RemoveDuplicates Columns:=1, Header:=xlNo
    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
    f2.Range("B2:B" & DerLig_f2).FormulaR1C1 = "=round(SUMIF('" & f1.Name & "'!R19C13:R" & DerLig_f1 & "C13,RC1,'" & f1.Name & "'!R19C11:R" & DerLig_f1 & "C11)-SUMIF('" & f1.Name & "'!R19C13:R" & DerLig_f1 & "C13,RC1,'" & f1.Name & "'!R19C12:R" & DerLig_f1 & "C12),2)"
    f2.Range("B2:B" & DerLig_f2).Value = f2.Range("B2:B" & DerLig_f2).Value
    f2.AutoFilterMode = False
    'DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
 
    f2.Range("C2").FormulaArray = "=IFERROR(INDEX('" & f1.Name & "'!R18C2:R" & DerLig_f1 & "C15,MATCH(1,('" & f1.Name & "'!R18C13:R" & DerLig_f1 & "C13=RC1)*('" & f1.Name & "'!R18C11:R" & DerLig_f1 & "C11=RC2),0),7),""X"")"
    f2.Range("C2").AutoFill Destination:=f2.Range("C2:C" & DerLig_f2)
    f2.Range("C2:C" & DerLig_f2).Value = f2.Range("C2:C" & DerLig_f2).Value
 
    'Recherche de dates non conformes liées à un débit constitué de plusieurs valeurs
    Nb_x = Application.CountIf(f2.Range("C2:C" & DerLig_f2), "X")
    If Nb_x <> 0 Then
        ActiveWorkbook.Worksheets(f1.Name).Sort.SortFields.Clear
        ActiveWorkbook.Worksheets(f1.Name).Sort.SortFields.Add Key:=f1.Range("M19:M" & DerLig_f1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        ActiveWorkbook.Worksheets(f1.Name).Sort.SortFields.Add Key:=f1.Range("H19:H" & DerLig_f1), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets(f1.Name).Sort
            .SetRange f1.Range("H18:O" & DerLig_f1)
            .Header = xlYes
            .Apply
        End With
Suivant:
        Total_Debit = 0
        Debit = ""
        Credit = ""
        With f2.Range("C1:C" & DerLig_f2)
            Set d = .Find("X", LookAt:=xlWhole)
            If Not d Is Nothing Then
                Deb = d.Address
                Code = f2.Cells(d.Row, "A")
                Ecart = f2.Cells(d.Row, "B")
                Nb_Code = Application.CountIf(f1.Range("M19:M" & DerLig_f1), Code)
                With f1.Range("M19:M" & DerLig_f1)
                    Set c = .Find(Code, LookAt:=xlWhole)
                    J = c.Row + Nb_Code - 1 'Ligne la plus basse du code cherché
                    For i = c.Row + Nb_Code - 2 To c.Row - 1 Step -1
                        If f1.Cells(i, "K") <> f1.Cells(J, "L") And f1.Cells(i, "K") <> 0 Then
                            Total_Debit = Total_Debit + f1.Cells(i, "K")
                            If Credit <> Chr(10) & f1.Cells(J, "L") & ": " & f1.Cells(J, "H") Then Credit = Credit & Chr(10) & f1.Cells(J, "L") & ": " & f1.Cells(J, "H")
                            If Round(Total_Debit - f1.Cells(J, "L"), 2) <> Round(Ecart, 2) Then
                                Debit = Debit & Chr(10) & f1.Cells(i, "K") & ": " & f1.Cells(i, "H")
                            Else
                                Debit = Debit & Chr(10) & f1.Cells(i, "K") & ": " & f1.Cells(i, "H")
                                'If f1.Cells(J, "L") <> 0 Then Credit = Credit & Chr(10) & f1.Cells(J, "L") & ": " & f1.Cells(J, "H")
                                f2.Cells(d.Row, "C") = Right(Debit, Len(Debit) - 1)
                                f2.Cells(d.Row, "D") = Right(Credit, Len(Credit) - 1)
                                GoTo Suivant
                            End If
                        Else
                            If f1.Cells(i, "K") <> 0 Then J = J - 2
                        End If
                    Next i
                End With
            End If
        End With
    End If
 
    'Tri descendant pour mettre les zéros en fon ce tableau
    f2.Range("A2:D" & DerLig_f2).Sort [B1], 2
 
    'Suppression des zéros
    With f2.Range("B1:B" & DerLig_f2)
        Set z = .Find(0, LookAt:=xlWhole)
        If Not z Is Nothing Then Range(f2.Cells(z.Row, "A"), f2.Cells(DerLig_f2, "D")).Delete
    End With
 
    MsgBox "Traitement terminé"
    Set z = Nothing
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Cdlt

**Alex020181** · 10/07/2021, 00h36

Bonjour,

Tu trouveras en PJ une proposition de code.
Il te suffit de cliquer sur le bouton de la feuille "Résultats".

En cas de plusieurs mouvements le code reprend les différentes dates dans la même cellule.

Teste et dis-nous.

**ARTURO83** · 10/07/2021, 07h46

Bonjour,

Autre proposition différente de Alex020181 que je salue:
Pièce jointe 601412

Cdlt

**Alex020181** · 12/07/2021, 08h32

🤗 Bonne idée d'avoir ajouté les montants aux dates.

**Novice excel vba** · 12/07/2021, 09h54

Envoyé par Alex020181

🤗 Bonne idée d'avoir ajouté les montants aux dates.

Bonjour ARTURO83 et Alex020181,

Tout d'abord je voulais vous remerciez de votre travail et du temps passé (désolé je me suis pas connecter ce weekend), j'ai bien observé pour chacun vos travaux.

Pour celui de Alex020181, la macro est bonne mais il me manque certain détail comme d'abord supprimer les valeurs à zéros et aussi indiquer les montants détaillés des écritures en suspens.

Pour celui de ARTURO83, c'est exactement ce type de résultat que je voulais.

Je continue ma phase test sur d'autres comptes et je vous tiens au courant

Un grand merci encore une fois, bravo!

Cordialement,

**Alex020181** · 12/07/2021, 17h44

J'ai donc:
- supprimé les désignations 2 soldées
- ajouté dans la même cellule les dates et montants par sens et mouvements

Pour ce qui est de l'affichage je ne trouve pas que fusionner les dates et les montants dans la même cellule soit le mieux mais ça ce n'est qu'une question de préférence personnelle. Perso j'aurai ajouté les montants aux dates en 2 colonnes débits et 2 colonnes crédit.
Nom : Echantillon.png
Affichages : 740
Taille : 12,7 Ko

Nom : Echantillon.png
Affichages : 740
Taille : 12,7 Ko

Teste et dis nous.

**Pierre Fauconnier** · 13/07/2021, 07h43

Salut.

Je reviens avec mon idée Power Query:

Transformer ta source en tableau structuré (la base des bases, pour moi, que ce soit pour de l'Excel ou du VBA) => voir mon tuto à ce sujet;
Importer le tableau en Power Query;
Créer une référence sur ce tableau;
Supprimer les colonnes inutiles de la référence et garder uniquement Description2, débit et crédit;
Ajouter une colonne calculée Débit - Crédit;
Regrouper sur Description2 et filtrer sur les soldes différentes de 0 (avec un jeu d'arrondi);
Fusionner le tableau et la référence sur base de Description2.

Nom : 2021-07-13_074153.png
Affichages : 495
Taille : 111,4 Ko

Si je devais le faire en VBA, je procéderais de la même manière en m'appuyant sur les outils d'Excel. Ca ferait peu de code VBA, surtout en utilisant les tableaux structurés.

**Pierre Fauconnier** · 13/07/2021, 08h06

Manuellement, donc sans VBA et sans Power Query, ca prend à tout casser 10 minutes en "one shot" et 1 minute à chaque mise à jour...

Vider le tableau de base;
Vider le tableau des descriptions2;
Coller les données d'origine dans le tableau;
Coller la colonne description2 dans le tableau des description2;
supprimer les doublons sur cette colonne;
Les formules font le reste et il suffit de filtrer sur les "VRAI" de la dernière colonne des mouvements.

MouvementsLettrésManuel.xlsx

**Novice excel vba** · 13/07/2021, 09h52

Envoyé par Alex020181

J'ai donc:
- supprimé les désignations 2 soldées
- ajouté dans la même cellule les dates et montants par sens et mouvements

Pour ce qui est de l'affichage je ne trouve pas que fusionner les dates et les montants dans la même cellule soit le mieux mais ça ce n'est qu'une question de préférence personnelle. Perso j'aurai ajouté les montants aux dates en 2 colonnes débits et 2 colonnes crédit.
Nom : Echantillon.png
Affichages : 740
Taille : 12,7 Ko

Teste et dis nous.

Bonjour,

Trés bon travail merci!

j'aime beaucoup votre suggestion d'ajouter les montants aux dates en 2 colonnes débits et 2 colonnes crédit, mais je préfère cette présentation.

Juste une chose, il est possible aussi de remplacer la date comptable par la date GL.

Merci de votre contribution.

Cordialement,

**Novice excel vba** · 13/07/2021, 09h56

Envoyé par Pierre Fauconnier

Manuellement, donc sans VBA et sans Power Query, ca prend à tout casser 10 minutes en "one shot" et 1 minute à chaque mise à jour...

Vider le tableau de base;
Vider le tableau des descriptions2;
Coller les données d'origine dans le tableau;
Coller la colonne description2 dans le tableau des description2;
supprimer les doublons sur cette colonne;
Les formules font le reste et il suffit de filtrer sur les "VRAI" de la dernière colonne des mouvements.

MouvementsLettrésManuel.xlsx

Bonjour Pierre,

Je vous remercie de votre contribution! Mais il s'avère que dans la direction ou je travail, ils veulent que du vba.

Mais votre travail va me permettre de mettre en place des contrôles de cohérence sur d'autres comptes déjà automatisés.

Un grand merci.

Cordialement,

**ARTURO83** · 13/07/2021, 11h05

Bonjour,

Avec les dates GL
Pièce jointe 601537

Cdlt

automatisation Rapprochement bancaire

Macros et VBA Excel

Discussions similaires

Partager

Partager