Somme de cellule B et C en fonction de la cellule A
Bonjour,
Je sollicite votre aide pour une nouvelle Macro VBA
j'ai un fichier qui contient plusieurs profils, Architecte, Pilote projets etc... (sur la colonne A), je veux une macro qui fait comme suit :
Faire la somme de cellule B et C en fonction de la cellule A, j'ai commencé le code suivant mais ça marche pas
k=0
l = 0
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
l= Range("B" & i)
k= Range("C" & i)
If Range("A" & i) = Range("A" & i+1) Then
l= Range("B" & i) + l
k= Range("B" & i) + k
Rows("i+1").Select.
Selection.Delete Shift:=xlUp.
Else
i ++
End If
Next
ci joint un exemple simple
bonjour,
une possibilité
Sub aargh()
Dim q(), s()
ReDim q(1 To 100), s(1 To 100)
Set d = CreateObject("scripting.dictionary")
i = 2
With Sheets("Ressources Net")
While .Cells(i, 1) <> ""
f = .Cells(i, 1)
If d.exists(f) Then j = d.Item(f) Else k = k + 1: d.Add f, k: j = k
q(j) = q(j) + .Cells(i, 2)
s(j) = s(j) + .Cells(i, 3)
i = i + 1
Wend
ReDim Preserve q(1 To k)
ReDim Preserve s(1 To k)
End With
With Sheets("ELS Ressources")
.Range("A2").Resize(d.Count, 1) = Application.Transpose(d.keys)
.Range("B2").Resize(d.Count, 1) = Application.Transpose(q)
.Range("C2").Resize(d.Count, 1) = Application.Transpose(s)
.Range("A2:C" & d.Count + 1).Sort key1:=.Range("A2"), order1:=xlAscending, Header:=xlNo
End With
End SubBonjour h2so4,
ça marche parfaitement
Merci
Rebonjour,
La solution marche bien, sauf que je dois faire le même traitement mais en fonction de deux colonne, du coup si le cellules de la colonne A(i) = Cellule de colonne A(i+1) voir si cellules de la colonne E(i) = Cellule de colonne E(i+1), on fait la somme et supprime le doublant.
Merci d'avance
Sub Tri()
Dim q(), s()
ReDim q(1 To 100), s(1 To 100)
Set d = CreateObject("scripting.dictionary")
i = 2
With Sheets("Ressources Net")
While .Cells(i, 1) <> ""
f = .Cells(i, 1)
If d.exists(f)
'Rajouter la condition si la cellule de la colonne E (i)<>E(+1) et recopier la colonne E parce que je tombe sur un instance
'de même nom mais pas forcement pour la meme personne
Then j = d.Item(f) Else k = k + 1: d.Add f, k: j = k
q(j) = q(j) + .Cells(i, 2)
s(j) = s(j) + .Cells(i, 3)
i = i + 1
Wend
ReDim Preserve q(1 To k)
ReDim Preserve s(1 To k)
End With
With Sheets("ELS Ressources")
.Range("A2").Resize(d.Count, 1) = Application.Transpose(d.keys)
.Range("B2").Resize(d.Count, 1) = Application.Transpose(q)
.Range("C2").Resize(d.Count, 1) = Application.Transpose(s)
.Range("A2:C" & d.Count + 1).Sort key1:=.Range("A2"), order1:=xlAscending, Header:=xlNo
End With
End Sub
h2so4 a écrit :bonjour,
une possibilité
Sub aargh() Dim q(), s() ReDim q(1 To 100), s(1 To 100) Set d = CreateObject("scripting.dictionary") i = 2 With Sheets("Ressources Net") While .Cells(i, 1) <> "" f = .Cells(i, 1) If d.exists(f) Then j = d.Item(f) Else k = k + 1: d.Add f, k: j = k q(j) = q(j) + .Cells(i, 2) s(j) = s(j) + .Cells(i, 3) i = i + 1 Wend ReDim Preserve q(1 To k) ReDim Preserve s(1 To k) End With With Sheets("ELS Ressources") .Range("A2").Resize(d.Count, 1) = Application.Transpose(d.keys) .Range("B2").Resize(d.Count, 1) = Application.Transpose(q) .Range("C2").Resize(d.Count, 1) = Application.Transpose(s) .Range("A2:C" & d.Count + 1).Sort key1:=.Range("A2"), order1:=xlAscending, Header:=xlNo End With End Sub
re-bonjour,
essaie ceci
Sub aargh()
Dim q(), s()
ReDim q(1 To 100), s(1 To 100)
Set d = CreateObject("scripting.dictionary")
i = 2
With Sheets("Ressources Net")
While .Cells(i, 1) <> ""
f = .Cells(i, 1) & " " & .cells(i,5)
If d.exists(f) Then j = d.Item(f) Else k = k + 1: d.Add f, k: j = k
q(j) = q(j) + .Cells(i, 2)
s(j) = s(j) + .Cells(i, 3)
i = i + 1
Wend
ReDim Preserve q(1 To k)
ReDim Preserve s(1 To k)
End With
With Sheets("ELS Ressources")
.Range("A2").Resize(d.Count, 1) = Application.Transpose(d.keys)
.Range("B2").Resize(d.Count, 1) = Application.Transpose(q)
.Range("C2").Resize(d.Count, 1) = Application.Transpose(s)
.Range("A2:C" & d.Count + 1).Sort key1:=.Range("A2"), order1:=xlAscending, Header:=xlNo
End With
End Sub
Merci pour les réponses aux précédentes, le tri fonctionne bien mais je rencontre une dernière difficulté, il fusionne le deux colonnes dans la même cellule puisque dans le ligne de code .Range("A2").Resize(d.Count, 1) = Application.Transpose(d.keys) et d.key comprends la valeur de la cellule 1 et 5
bonjour,
essaie ceci
Sub aargh()
Dim q(), s(), f1(), f2()
ReDim q(1 To 100), s(1 To 100), f1(1 To 100), f2(1 To 100)
Set d = CreateObject("scripting.dictionary")
i = 2
With Sheets("Ressources Net")
While .Cells(i, 1) <> ""
f = .Cells(i, 1) & " " & .Cells(i, 5)
If d.exists(f) Then j = d.Item(f) Else k = k + 1: d.Add f, k: j = k
q(j) = q(j) + .Cells(i, 2)
s(j) = s(j) + .Cells(i, 3)
f1(j) = .Cells(i, 1)
f2(j) = .Cells(i, 2)
i = i + 1
Wend
ReDim Preserve q(1 To k)
ReDim Preserve s(1 To k)
ReDim Preserve f1(1 To k)
ReDim Preserve f2(1 To k)
End With
With Sheets("ELS Ressources")
.Range("A2").Resize(d.Count, 1) = Application.Transpose(f1)
.Range("B2").Resize(d.Count, 1) = Application.Transpose(q)
.Range("C2").Resize(d.Count, 1) = Application.Transpose(s)
.Range("E2").Resize(d.Count, 1) = Application.Transpose(f2)
.Range("A2:E" & d.Count + 1).Sort key1:=.Range("A2"), order1:=xlAscending, key2:=.Range("E2"), order2:=xlAscending, Header:=xlNo
End With
End Sub
Re Bonjour @h2so4 et grand merci
ça marche trés biennn
par contre quand j'ai rajouté un autre ligne de code j'ai un beug
Sub aargh()
Dim q(), s(), f1(), f2(), f3()
ReDim q(1 To 100), s(1 To 100), f1(1 To 100), f2(1 To 100), f3(1 To 100)
Set d = CreateObject("scripting.dictionary")
i = 2
With Sheets("Ressources Net")
While .Cells(i, 1) <> ""
f = .Cells(i, 1) & " " & .Cells(i, 5)
If d.exists(f) Then j = d.Item(f) Else k = k + 1: d.Add f, k: j = k
q(j) = q(j) + .Cells(i, 2)
s(j) = s(j) + .Cells(i, 3)
f1(j) = .Cells(i, 1)
f2(j) = .Cells(i, 2)
f3(j) = .Cells(i, 2) / .Cells(i, 3)
i = i + 1
Wend
ReDim Preserve q(1 To k)
ReDim Preserve s(1 To k)
ReDim Preserve f1(1 To k)
ReDim Preserve f2(1 To k)
ReDim Preserve f3(1 To k)
End With
With Sheets("ELS Ressources")
.Range("A2").Resize(d.Count, 1) = Application.Transpose(f1)
.Range("B2").Resize(d.Count, 1) = Application.Transpose(q)
.Range("C2").Resize(d.Count, 1) = Application.Transpose(s)
.Range("E2").Resize(d.Count, 1) = Application.Transpose(f2)
.Range("F2").Resize(d.Count, 1) = Application.Transpose(f3)
.Range("A2:E" & d.Count + 1).Sort key1:=.Range("A2"), order1:=xlAscending, key2:=.Range("E2"), order2:=xlAscending, Header:=xlNo
End With
End Sub
bonjour,
as-tu un message d'erreur ? sur quelle instruction ?
Non j'ai pas de message d’erreur
re-bonjour,
quel est alors le problème ?
une proposition de correction de tes ajouts, mais pas sûr d'avoir compris ce que tu cherches à faire.
Sub aargh()
Dim q(), s(), f1(), f2(), f3()
ReDim q(1 To 100), s(1 To 100), f1(1 To 100), f2(1 To 100), f3(1 To 100)
Set d = CreateObject("scripting.dictionary")
i = 2
With Sheets("Ressources Net")
While .Cells(i, 1) <> ""
f = .Cells(i, 1) & " " & .Cells(i, 5)
If d.exists(f) Then j = d.Item(f) Else k = k + 1: d.Add f, k: j = k
q(j) = q(j) + .Cells(i, 2)
s(j) = s(j) + .Cells(i, 3)
f1(j) = .Cells(i, 1)
f2(j) = .Cells(i, 5)
If s(j) <> 0 Then f3(j) = q(j) / s(j)
i = i + 1
Wend
ReDim Preserve q(1 To k)
ReDim Preserve s(1 To k)
ReDim Preserve f1(1 To k)
ReDim Preserve f2(1 To k)
ReDim Preserve f3(1 To k)
End With
With Sheets("Ressources Personnes")
.Range("A2").Resize(d.Count, 1) = Application.Transpose(f1)
.Range("B2").Resize(d.Count, 1) = Application.Transpose(q)
.Range("C2").Resize(d.Count, 1) = Application.Transpose(s)
.Range("D2").Resize(d.Count, 1) = Application.Transpose(f2)
.Range("E2").Resize(d.Count, 1) = Application.Transpose(f3)
.Range("A2:F" & d.Count + 1).Sort key1:=.Range("A2"), order1:=xlAscending, key2:=.Range("E2"), order2:=xlAscending, Header:=xlNo
End With
End Subje voulais pour chaque ligne diviser B / C
Rouritta a écrit :je voulais pour chaque ligne diviser B / C
dans ce cas, je pense t'avoir donné la solution.
En faite je disais des bêtises :p non je voulais B / le total de C et pas B / C, la solution marche bien sauf que j'ai mal expliqué
Bonjour @h2so4
Je ne sais pas si vous pouvez m'aidez encore, j'ai une erreur sur la somme de mes colonne et je n'arrive pas à savoir pkoi, quand je fait ma somme selon le profil, sur le profil BI, il me manque 10 !! alors que quand je fait la somme selon e nom j'ai ma somme complète alors que j'ai utilisé le même principe.
Merci d'avance
Voici mes deux macros:
Sub Report_Personne()
'Ressources Par Collaborateurs
Dim q(), s(), r(), f1(), f2(), f3(), f4()
ReDim q(1 To 100), s(1 To 100), r(1 To 100), f1(1 To 100), f2(1 To 100), f3(1 To 100), f4(1 To 100)
Set d = CreateObject("scripting.dictionary")
i = 2
With Sheets("Ressources Net")
While .Cells(i, 1) <> ""
f = .Cells(i, 1)
If d.exists(f) Then j = d.Item(f) Else k = k + 1: d.Add f, k: j = k
q(j) = q(j) + .Cells(i, 6)
s(j) = s(j) + .Cells(i, 7)
'r(j) = r(j) + .Cells(i, 8)
r(j) = q(j) + s(j)
f1(j) = .Cells(i, 1)
f2(j) = .Cells(i, 2)
If r(j) <> 0 Then f3(j) = q(j) / r(j)
If r(j) <> 0 Then f4(j) = s(j) / r(j)
i = i + 1
Wend
ReDim Preserve q(1 To k)
ReDim Preserve s(1 To k)
ReDim Preserve f1(1 To k)
ReDim Preserve f2(1 To k)
End With
With Sheets("Collaborateurs")
.Range("C6").Resize(d.Count, 1) = Application.Transpose(f1)
.Range("D6").Resize(d.Count, 1) = Application.Transpose(f2)
.Range("E6").Resize(d.Count, 1) = Application.Transpose(q)
.Range("F6").Resize(d.Count, 1) = Application.Transpose(s)
.Range("G6").Resize(d.Count, 1) = Application.Transpose(r)
.Range("H6").Resize(d.Count, 1) = Application.Transpose(f3)
.Range("I6").Resize(d.Count, 1) = Application.Transpose(f4)
.Range("C6:I6" & d.Count + 1).Sort key1:=.Range("C6"), order1:=xlAscending, order2:=xlAscending, Header:=xlNo
End With
End Sub
Sub Report_Fonction()
' Ressource Par Profil
Dim q(), s(), r(), f1(), f2(), f3()
ReDim q(1 To 100), s(1 To 100), r(1 To 100), f1(1 To 100), f2(1 To 100), f3(1 To 100)
Set d = CreateObject("scripting.dictionary")
i = 2
With Sheets("Ressources Net")
While .Cells(i, 2) <> ""
f = .Cells(i, 2)
If d.exists(f) Then j = d.Item(f) Else k = k + 1: d.Add f, k: j = k
q(j) = q(j) + .Cells(i, 6)
s(j) = s(j) + .Cells(i, 7)
r(j) = q(j) + s(j)
f1(j) = .Cells(i, 2)
If r(j) <> 0 Then f2(j) = q(j) / r(j)
If r(j) <> 0 Then f3(j) = s(j) / r(j)
i = i + 1
Wend
ReDim Preserve q(1 To k)
ReDim Preserve s(1 To k)
ReDim Preserve f1(1 To k)
'ReDim Preserve f2(1 To k)
End With
With Sheets("Profil")
.Range("C6").Resize(d.Count, 1) = Application.Transpose(f1)
.Range("D6").Resize(d.Count, 1) = Application.Transpose(q)
.Range("E6").Resize(d.Count, 1) = Application.Transpose(s)
.Range("F6").Resize(d.Count, 1) = Application.Transpose(r)
.Range("G6").Resize(d.Count, 1) = Application.Transpose(f2)
.Range("H6").Resize(d.Count, 1) = Application.Transpose(f3)
.Range("C6:H6" & d.Count + 1).Sort key1:=.Range("C6"), order1:=xlAscending, order2:=xlAscending, Header:=xlNo
End With
End Sub
Je met comme même mon fichier en pièce jointe
bonjour,
l'erreur vient de cette instruction dans ta macro report-fonction
While .Cells(i, 2) <> ""la macro s'arrête dès qu'elle rencontre une cellule vide en colonne B, or pour sylvain tu n'as pas de profil, la macro s'arrête donc sur la ligne de sylvain et ne prend donc pas en compte les lignes suivantes.
corrige l'instruction ainsi
While .Cells(i, 1) <> ""Bonjour h2so4
Merci beaucoup, l'erreur à disparu, par contre j'ai pas compris pourquoi avant j'ai testé et j'avais pas ce soucis.
Merci encore une fois.
Bonne journée
Rouritta a écrit :Bonjour h2so4
Merci beaucoup, l'erreur à disparu, par contre j'ai pas compris pourquoi avant j'ai testé et j'avais pas ce soucis.
Merci encore une fois.
Bonne journée
avec le code avant ma correction et les données que tu avais, tu devais avoir le souci.
Bonjour h2so4
Oui je vois bien
Bonne journée