Création d'un nouveau programme qui ne fonctionne pas
Bonjour le fil,
paterbleutch, Là cela change la donne, au vu des données, je pense que Power Query sera votre meilleur amis, mais ce n'est pas le mien.
Il va se trouver sûrement quelqu'un pour pondre une requête aux petits oignons...
Jean-Paul, Votre code fonctionne très bien dans votre classeur
Dim headeetcrNames As Variant
headerNames = ThisWorkbook.Worksheets("R1").Range("A1:L1").Value
J'ai toujours dans mon classeur, en reprenant exactement votre code sans rien y changer, "l'indice n'appartient pas à la sélection :
Je viens de constater dans la colonne de Gauche VBA Projet de votre classeur test-ecritures-cumuls.xlsm
VBAProject (test-ecritures-cumuls.xlsm)
Microsoft Excel objects
sh_Accueil (Accueil)
sh_Cumuls (Cumuls)
sh_R1 (R1)
sh_R2 (R2)
sh_R3 (R3)
et dans le classeur apparait Accueil, R1, R2, R3, Cumuls. Dans votre code vous utilisez "sh_Cumul"
Dans mon classeur
Dans mon VBAProject (Végétaux.xlsm)
Microsoft Excel objects
Feuil10 (R10)
Feuil9 (R6)
Etc.
Je ne serai pas étonné que l’appellation de mes feuilles ne convient pas mais je ne sais pas comment reproduire votre façon de nommer les feuilles.
Est ce que je me trompe? Si oui pouvez-vous m'expliquer?
Bonjour le fil,
paterbleutch, Dans l'environnement VBE, Sélectionnez une feuille dans l'explorateur de projet sur la gauche, le premier Name (En rouge) sur la droite est son CodeName, le second plus bas (En vert) est son nom (onglet)
Vous pouvez changer les deux ou un seul ici.
Vous remarquerez que certaines feuilles (Système) son précédées du préfixe "sys_" cela me permet par exemple de cacher très facilement les feuilles système si je le veux. Les autres ont le préfixe "sh_".
Si vous ne voyez pas l'explorateur de projet faites [ALT] + F11 pour basculer dans l'environnement VBE, puis [CTRL] + R pour afficher l'explorateur de projet. Et ensuite F4 pour les propriétés.
Mais par rapport à ce que vous avez montré ce code ne sera pas suffisant. Il ne fait que recopier les lignes sans faire les totaux. Et d’après ce que vous montrez, le tableau de cumul fait le total pour les lignes identiques.
Bonjour,
Avec l'exemple envoyé, il est possible de tout regrouper via power query, j'ai essayé mais je connais assez mal cet outil; il reste aussi le VBA (je n'ai pas essayé) aussi mais en nettoyant les onglets Mois1-Moi2 et Mois3 auparavant..
Je mets quand même résultat obtenu.
P.
Bonjour le fil,
paterbleutch, J'ai tenté de me caler sur l'exemple donné, et voici un code minimaliste en VBA.
J'ai supprimer les lignes vides avant les tableaux.
Option Explicit
Public Sub ConstruireCumuls()
'// On teste si la feuille éxiste, sinon on la crée.
On Error Resume Next
Dim sheetCumuls As Worksheet
Set sheetCumuls = ThisWorkbook.Worksheets("MoisCumuls")
On Error GoTo 0
If sheetCumuls Is Nothing Then
Set sheetCumuls = ThisWorkbook.Worksheets.Add
sheetCumuls.Name = "MoisCumuls"
End If
'// Dictionnaire pour cumuls
Dim dictionnaire As Object
Set dictionnaire = CreateObject("Scripting.Dictionary")
dictionnaire.CompareMode = vbTextCompare
'// Parcours de toutes les feuilles sauf Cumuls
Dim sheetSource As Worksheet
For Each sheetSource In ThisWorkbook.Worksheets
If sheetSource.CodeName Like "sh_Mois*" Then
Dim lastRow As Long
lastRow = sheetSource.Cells(sheetSource.Rows.Count, "A").End(xlUp).Row
Dim titreCourant As String
titreCourant = vbNullString
Dim i As Long
For i = 1 To lastRow
Dim vDate1 As Variant
vDate1 = sheetSource.Cells(i, "A").Value
Dim vDate2 As Variant
vDate2 = sheetSource.Cells(i, "B").Value
Dim vNature As Variant
vNature = sheetSource.Cells(i, "C").Value
Dim vAchat As Variant
vAchat = sheetSource.Cells(i, "D").Value
Dim vVente As Variant
vVente = sheetSource.Cells(i, "E").Value
'// Ligne vide complète ? on saute
If IsEmpty(vDate1) And IsEmpty(vDate2) And _
IsEmpty(vNature) And IsEmpty(vAchat) And IsEmpty(vVente) Then
GoTo NextRow
End If
'// Détection d'un titre : Nature non vide, montants vides
If Not IsEmpty(vNature) And IsEmpty(vAchat) And IsEmpty(vVente) _
And IsEmpty(vDate2) And vDate1 = "Titre" Then
titreCourant = CStr(vNature)
GoTo NextRow
End If
'// Lignes à ignorer : sous-totaux, totaux, bénéfices
If Not IsEmpty(vNature) Then
If InStr(1, vNature, "Somme", vbTextCompare) > 0 _
Or InStr(1, vNature, "TOTAL", vbTextCompare) > 0 _
Or InStr(1, vNature, "Bénéfice", vbTextCompare) > 0 Then
GoTo NextRow
End If
End If
'// Lignes de données : on doit avoir une Nature et au moins un montant
If titreCourant <> "" And Not IsEmpty(vNature) Then
Dim nature As String
nature = CStr(vNature)
Dim achat As Double
If IsNumeric(vAchat) Then achat = CDbl(vAchat) Else achat = 0
Dim vente As Double
If IsNumeric(vVente) Then vente = CDbl(vVente) Else vente = 0
'// Clé = Titre|Nature
Dim key As String
key = titreCourant & "|" & nature
If Not dictionnaire.Exists(key) Then
dictionnaire.Add key, Array(titreCourant, nature, achat, vente)
Else
Dim arr
arr = dictionnaire(key)
arr(2) = arr(2) + achat
arr(3) = arr(3) + vente
dictionnaire(key) = arr
End If
End If
NextRow:
Next i
End If
Next sheetSource
'// Écriture sur la feuille Cumuls
EcrireCumuls sheetCumuls, dictionnaire
MsgBox "Tableau de cumuls généré sur la feuille 'Cumuls'.", vbInformation
End Sub
Private Sub EcrireCumuls(ByVal ws As Worksheet, ByVal d As Object)
ws.Cells.Clear
'// En-têtes
ws.Range("A1").Value = "Titre"
ws.Range("B1").Value = "Nature"
ws.Range("C1").Value = "Achat €"
ws.Range("D1").Value = "Vente €"
Dim ligne As Long
ligne = 2
Dim titreCourant As String
titreCourant = ""
'// On parcourt les éléments triés par Titre puis Nature
Dim keys As Variant
keys = d.keys
Call TriAlpha(keys)
Dim i As Long
For i = LBound(keys) To UBound(keys)
Dim arr As Variant
arr = d(keys(i))
Dim titre As String
titre = arr(0)
'// Si le titre change ? on l'affiche une seule fois
If titre <> titreCourant Then
ws.Cells(ligne, "A").Value = titre
ws.Cells(ligne, "A").Font.Bold = True
titreCourant = titre
ligne = ligne + 1
End If
'// Ligne de Nature indentée
ws.Cells(ligne, "B").Value = " " & arr(1)
ws.Cells(ligne, "C").Value = arr(2)
ws.Cells(ligne, "D").Value = arr(3)
ligne = ligne + 1
Next i
'// Mise en forme
With ws.Range("A1:D1")
.Font.Bold = True
.Interior.Color = RGB(220, 220, 220)
End With
ws.Columns("A:D").AutoFit
End Sub
Private Sub TriAlpha(arr As Variant)
Dim i As Long, j As Long
Dim temp As Variant
For i = LBound(arr) To UBound(arr) - 1
For j = i + 1 To UBound(arr)
If arr(j) < arr(i) Then
temp = arr(i)
arr(i) = arr(j)
arr(j) = temp
End If
Next j
Next i
End SubEt pour le test un petit fichier.
Je n'ai pas tout testé, j'éspère que l'on est bon.
re,
cela demande presque une solution avec l'aide d'un dictionaire de dictionaires, mais cela est d'un niveau qui n'est pas pour des "débutants".