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".
Jean-Paul, patrick1957, BsAlv, merci pour vos réponses
BsAlv, Merci de suivre, pour le "dictionnaire" cela ne va pas être évident à comprendre
patrick1957, Comme je l'ai déjà écrit je ne sais absolument pas comment fonctionne Power Query et ce que cela peut m'apporter. Comme j'ai commencé avec du code je vais continuer avec le code. Merci pour votre intervention.
Jean-Paul, Votre première réponse sur le VBA object m'apprend des choses que j’ignorais. Votre code va me donner du mal pour comprendre mais je finirai par y arriver. Dans un premier temps je vais voir, pour l'appellation des feuilles, si cela résout mon problème de "l'indice qui ne fait pas partie de la sélection".
Bonjour le fil,
BsAlv, Merci de suivre, pour le "dictionnaire" cela ne va pas être évident à comprendre
paterbleutch, Un petit tour par ici vous en apprendra beaucoup sur les objets Excel, à lire sans modération
Bonne programmation, Jean-Paul.
Jean-Paul, Compte tenu de ce que vous m'avez écrit dans les propriétés des feuille où il y a "(Name)" et "Name" j'ai écrit pour les deux "Name" le même nom R1 et R1.
et j'ai repris le programme à zéro et je bute toujours sur le même problème, "L'indice n'appartient pas à la sélection en utilisant sheets("R1") puis sheets("R" & feuille)
Je ne comprend pas puisque cela fonctionne dans votre classeur
Sub MoisCumules()
Dim zoneR As Variant
Dim wsMois As Worksheet
Dim wsCumul As Worksheet
Dim feuille As Long
feuille = 1
Dim headerNames As Variant
headerNames = ThisWorkbook.Worksheets("R1").Range("A1:L1").Value 'l'indice n'appartient pas à la sélection
Set wsMois = Sheets("R1")
Set wsCumul = Sheets("Cumul")
Set zoneR = ThisWorkbook.WorkSheets("R1").Range("A1:L1).Value 'l'indice n'appartient pas à la sélection
End SubRe,
paterbleutch, Faites une copie d'écran (Du projet sous VBE) ou envoyez votre fichier il doit encore y avoir un nom qui coince.
Sur l'image vous voyez le codeName de la feuille suivi de son Nom entre parenthèses. Pour les appels c'est soit :
- Directement avec son CodeName :
Dim headerNames As Variant
headerNames = sh_R1.Range("A1:L1").Value- Soit avec son nom dans la collection Worksheets
Dim headerNames As Variant
ThisWorkbook.Worksheets("R1").ValueN'oubliez pas non plus que vous faites une boucle sur toutes les feuilles...
Dans votre second exemple les feuilles se nommées "Mois1", "Mois2" etc...
re, 2 solutions avec des dictionaires, l'un avec un dictionaire de dictionaires,l'autre une combinaison d'un dictionaire et un array, le dictionaire sert à savoir quelle ligne il faut actualiser. Ultra-rapide, parce qu'on écrit une fois vers la feuille.
Range("A1:L1).Valueil manque un " après L1, je suppose
et Set zoneR, cela me semble pas correct
PS. sorry, je n'avais pas vu que Jean-Paul (Salut) a répondu