Discussion :

[1pim34]

Bonjour,

J'ai un fichier excel que je souhaite modifier via une macro VBA pour pouvoir faire des échanges réguliers avec des clients.

Classeur2.xlsx

J'ai joint le classeur 2 qui est le fichier d'origine.
Je joins également le format du fichier que je dois obtenir.

En gros, il faut que dans la colonne A, dans laquelle j'ai le jour d'une écriture, le format de cellule soit modifier au format JJMMAAAA en récupérant le Mois et l'Année dans la cellule E3.
Dans l'exemple fourni il faudrait donc que la valeur de A4 soit en fin de compte 31032023.
Ensuite insérer en colonne B une colonne intitulée Journal dans laquelle les cellules doivent être ODR quand il y a une date dans la colonne A
Prendre la colonne D et en faire la colonne C
Créer une colonne D nommée Auxiliaire
Créer un colonne sens dans laquelle il faut mettre un D si la cellule correspondante de la colonne F du tableau d'origine est non nulle, mettre un C si la cellule correspondante de la colonne G du tableau d'origine est non nulle.
Fusionner les colonnes F et G du tableau d'origine en ne conservant que les valeurs non nulles
La colonne C du tableau d'origine doit se trouver en colonne G
Enfin, la colonne B du tableau d'origine doit se trouver en colonne H

Je suis désolé, j'espère avoir été suffisamment clair. Si besoin ne pas hésiter à me demander.

Merci beaucoup d'avance si une âme charitable veut bien se pencher sur ma question.

[Franc]

Salut, j'ai beaucoup de mal à suivre, entre tes insertions et déplacements de colonnes, je ne visualise pas le résultat final. Une capture écran après traitement pourrait aider.

[1pim34]

Voici ce à quoi il faudrait que ca ressemble après modification.

Merci

[BENNASR]

Bonjour
tester ça :

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
Sub regroup()
Application.ScreenUpdating = False
Dim F1 As Worksheet
Dim F2 As Worksheet
Set F1 = Sheets("Feuil1")
Set F2 = Sheets("RESULTAT")
F2.Cells.ClearContents
Dim i As Long
On Error Resume Next
Set d = CreateObject("Scripting.Dictionary")
F2.Cells(1, 1).Resize(1, 8) = Array("Jour", "Journal", "Compte", "Auxiliaire", "Sens", "Montant", "Libellé Ecriture", "Pièce")
    TblBD = F1.Range("A1:G" & F1.Range("G" & Rows.Count).End(xlUp).Row)
    For i = 4 To UBound(TblBD)
    If TblBD(i, 6) <> 0 Then
    clé = Format(CDate(TblBD(i, 1) + F1.Cells(2, "E") - 1), "m/d/yyyy") & "|" & F1.Cells(2, "D") & "|" & TblBD(i, 4) & "|" & "" & "|" & "D" & "|" & TblBD(i, 6) & "|" & TblBD(i, 5) & "|" & TblBD(i, 2)
    Else
    clé = Format(CDate(TblBD(i, 1) + F1.Cells(2, "E") - 1), "m/d/yyyy") & "|" & F1.Cells(2, "D") & "|" & TblBD(i, 4) & "|" & "" & "|" & "C" & "|" & TblBD(i, 7) & "|" & TblBD(i, 5) & "|" & TblBD(i, 2)
    End If
    d(clé) = d(clé)
    Next i
 F2.Range("A2").Resize(d.Count) = Application.Transpose(d.keys)
 Application.DisplayAlerts = False
 F2.Range("A2").Resize(d.Count).TextToColumns Other:=1, DataType:=xlDelimited, OtherChar:="|"
Application.ScreenUpdating = True
End Sub

[1pim34]

Merci beaucoup BENNASR, ça semble fonctionner comme attendu.

Merci encore et bonne journée.

[1pim34]

Bonjour,

je me permets de relancer ce topic car je me rends compte que quelque chose d'inattendu se produit :

source.xlsx

Ceci est le fichier source dont le contenu doit être collé dans le fichier suivant sur la feuil1.

1pim34 .xlsm

Ici le fichier avec la macro.
J'ai surligné en jaune 2 ligne dans la feuil1 et 1 ligne dans la feuil RESULTAT.

Pour une raison qui m'échappe, 1 des 2 lignes ne remontent pas dans ma feuille de RESULTAT.

Voici le code de la macro :

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
 
Sub regroup()
Application.ScreenUpdating = False
 
Dim lastRow As Long
Dim j As Long
lastRow = ActiveSheet.Cells(Rows.Count, "E").End(xlUp).Row
 
If Range("A1") = "Edition Journaux" Then
    Rows(1).Delete
End If
Range("D2") = "ODR"
 
For j = lastRow To 2 Step -1
    If Range("E" & j).Value = "Total Cumulé" Or Range("E" & j).Value = "Total Mois" Or Range("E" & j).Value = "Total Général" Then
        Rows(j).Delete
    End If
Next j
 
 
 
 
 
Dim F1 As Worksheet
Dim F2 As Worksheet
Set F1 = Sheets("Feuil1")
Set F2 = Sheets("RESULTAT")
F2.Cells.ClearContents
Dim i As Long
On Error Resume Next
Set d = CreateObject("Scripting.Dictionary")
F2.Cells(1, 1).Resize(1, 8) = Array("Jour", "Journal", "Compte", "Auxiliaire", "Sens", "Montant", "Libellé Ecriture", "Pièce")
    TblBD = F1.Range("A1:G" & F1.Range("G" & Rows.Count).End(xlUp).Row)
    For i = 3 To UBound(TblBD)
    If TblBD(i, 6) <> 0 Then
    clé = Format(CDate(TblBD(i, 1) + F1.Cells(2, "E") - 1), "m/d/yyyy") & "|" & F1.Cells(2, "D") & "|" & TblBD(i, 4) & "|" & "" & "|" & "D" & "|" & TblBD(i, 6) & "|" & TblBD(i, 5) & "|" & TblBD(i, 2)
    Else
    clé = Format(CDate(TblBD(i, 1) + F1.Cells(2, "E") - 1), "m/d/yyyy") & "|" & F1.Cells(2, "D") & "|" & TblBD(i, 4) & "|" & "" & "|" & "C" & "|" & TblBD(i, 7) & "|" & TblBD(i, 5) & "|" & TblBD(i, 2)
    End If
    d(clé) = d(clé)
    Next i
 F2.Range("A2").Resize(d.Count) = Application.Transpose(d.keys)
 Application.DisplayAlerts = False
 F2.Range("A2").Resize(d.Count).TextToColumns Other:=1, DataType:=xlDelimited, OtherChar:="|"
Application.ScreenUpdating = True
 
 
End Sub

Quand je prends uniquement les 2 lignes jaunes la macro s'effectue correctement.
Pour une raison qui m'échappe ce n'est pas le cas quand j'ai la totalité de mon fichier.

Merci d'avance pour votre aide, je ne comprends pas pourquoi cela ne fait pas la chose attendue