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 |
Partager