Générer les écritures comptables en VBA en filtrant certaines données

Version imprimable

1 pièce(s) jointe(s)

bonjour le forum

Je vous écris car j'ai besoin de votre aide pour générer des écritures comptables avec une macro en filtrant certaines données de notre premières fiche

Le but étant de : Par la feuille 1(regarde exemple) générer les écritures de la feuilles 2

pour y arriver j'utilise une macro mais je n'arrive pas a l'adapter

Est ce que quelqu'un pourrait m'aider s'il vous plait ?

Voici ma macro et le fichier ci-dessous est mon exemple La base de données (Feuil1)

cordialement Merci

Code:

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
Sub MacroFactures()
 
'
' Test Macro
'
Dim i%, iRC&, WsC As Worksheet, THdr
Application.ScreenUpdating = False
Worksheets.Add.Name = "FiltreReglement" & Worksheets.Count + 1
Set WsC = ActiveSheet
THdr = Split("date rgt,code journal,compte,débit,crédit,Libellé,pièce,référence pièce", ",")
    For i = 0 To UBound(THdr)
    WsC.Cells(2, 1 + i) = THdr(i)
    Next
        iRC = 3
        ArrS = Feuil1.[A1].CurrentRegion.Value2
        For i = 2 To UBound(ArrS)
        THdr(0) = Format(CDate(ArrS(i, 3)), "dd/mm/yyyy")
        THdr(1) = "RGLT"
        THdr(2) = "411" & ArrS(i, 5)
        THdr(3) = ""
        THdr(4) = ArrS(i, 12)
        THdr(5) = ArrS(i, 6)
        THdr(6) = ArrS(i, 10)
        THdr(7) = ArrS(i, 13)
        WsC.Cells(iRC, 1).Resize(1, UBound(THdr) + 1) = THdr
        iRC = iRC + 1
        THdr(3) = ArrS(i, 11)
        THdr(4) = ""
        WsC.Cells(iRC, 1).Resize(1, UBound(THdr) + 1) = THdr
        iRC = iRC + 1
        Next
 
    Columns("F:F").ColumnWidth = 26.14
    Columns("G:G").ColumnWidth = 31.57
    Columns("H:H").ColumnWidth = 19.14
    Columns("B:B").ColumnWidth = 15
 
        Range("A2:H2").Select
    Selection.Font.Bold = True
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
End Sub

le rendu (Feuil2)

1 pièce(s) jointe(s)

bonjour
je propose ce ci :

Code:

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
Sub comptabiliser()
Dim F1 As Worksheet
Dim F2 As Worksheet
Set F1 = Sheets("Feuil1")
Set F2 = Sheets("Compta")
Dim Tablo
 
F2.Cells.ClearContents
Dim i As Long
Application.ScreenUpdating = False
 
Tablo = F1.Range("A2", "Z" & F1.Range("A" & Rows.Count).End(xlUp).Row)
F2.Cells(1, 1).Resize(1, 8) = Array("Date", "code journal", "compte", "débit", "crédit", "Libellé pièce", "Pièce", "référence pièce")
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
 
    For i = 1 To UBound(Tablo)
    clé = Tablo(i, 2) & "|" & Tablo(i, 9) & "|" & "70600000" & "|" & "" & "|" & Tablo(i, 10) & "" & "|" & Tablo(i, 6) & "|" & Tablo(i, 1) & "|" & Tablo(i, 9)
    clé1 = Tablo(i, 2) & "|" & Tablo(i, 9) & "|" & "44571200" & "|" & "" & "|" & Tablo(i, 11) & "" & "|" & Tablo(i, 6) & "|" & Tablo(i, 1) & "|" & Tablo(i, 9)
    clé2 = Tablo(i, 2) & "|" & Tablo(i, 9) & "|" & "411" & Tablo(1, 5) & "|" & Tablo(i, 12) & "" & "|" & "" & "|" & Tablo(i, 6) & "|" & Tablo(i, 1) & "|" & Tablo(i, 9)
    d(clé) = d(clé)
    d1(clé1) = d1(clé1)
    d2(clé2) = d2(clé2)
    Next i
 
 
 F2.Range("A2").Resize(d.Count) = Application.Transpose(d.keys)
 F2.Range("A2").Resize(d.Count).TextToColumns Other:=1, DataType:=xlDelimited, OtherChar:="|"
 j = F2.Cells(Rows.Count, 1).End(xlUp).Row + 1
 F2.Range("A" & j).Resize(d.Count) = Application.Transpose(d1.keys)
 F2.Range("A" & j).Resize(d.Count).TextToColumns Other:=1, DataType:=xlDelimited, OtherChar:="|"
 L = F2.Cells(Rows.Count, 1).End(xlUp).Row + 1
 F2.Range("A" & L).Resize(d.Count) = Application.Transpose(d2.keys)
 F2.Range("A" & L).Resize(d.Count).TextToColumns Other:=1, DataType:=xlDelimited, OtherChar:="|"
F2.Select
Call flitrer
Application.ScreenUpdating = True
 
 
End Sub

puis filtrer avec :

Code:

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
Sub flitrer()
 
Dim DerLig As Long
 
    Application.ScreenUpdating = False
 
        With Sheets("Compta")
            .Select
            .AutoFilterMode = False
            DerLig = .Range("A" & Rows.Count).End(xlUp).Row
            .Range("A1:H" & DerLig).Select
            .Sort.SortFields.Clear
            .Sort.SortFields.Add Key:=Range("G1:G" & DerLig) _
                , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With .Sort
                .SetRange Range("A1:H" & DerLig)
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
 
        End With
 
End Sub

16/05/2022, 17h19
DragZZ

Mille merci

Bonjour Monsieur

tout est bon merci beaucoup mille mercis