vba pour calculer le temps total passé par type de catégories

superbog

XLDnaute Occasionnel
Bonjour,

Voilà, j'ai une liste de temps (tps) et de catégories (dil), le problème est que le nombre de catégories est variable, de même que le nombre de lignes.

Je voudrais qu'une macro me permette de faire le calcul du temps passé total par catégorie. Le problème est que je sèche.

L'idée est simple:

il faut faire une boucle sur la colonne dil et les tps de toutes les dil identiques font un total

Mais je n'y arrive pas

Ci joint fichier test.

merci d'avance
 

Pièces jointes

  • testbat.xlsm
    18.6 KB · Affichages: 32

job75

XLDnaute Barbatruc
Re : vba pour calculer le temps total passé par type de catégories

Bonsoir superbog, djidji59430,

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim dest As Range, t, d As Object, i&
Set dest = [H10] 'cellule de destination, à adapter
t = [A7].CurrentRegion.Resize(, 6) 'à adapter si nécessaire
Set d = CreateObject("Scripting.Dictionary")
Application.EnableEvents = False
If UBound(t) > 1 Then
  For i = 2 To UBound(t)
    If Not IsNumeric(t(i, 4)) Then t(i, 4) = 0
    d(t(i, 2)) = d(t(i, 2)) + t(i, 4)
  Next
  dest.Resize(d.Count) = Application.Transpose(d.keys)
  dest(1, 2).Resize(d.Count) = Application.Transpose(d.items)
  dest.Resize(d.Count, 2).Sort dest, xlAscending, Header:=xlNo 'tri
End If
dest.Offset(d.Count).Resize(Rows.Count - d.Count - dest.Row + 1, 2).ClearContents
Application.EnableEvents = True
End Sub
Fichier joint.

Edit
: ajouté le test sur t(i, 4)

Bonne nuit.
 

Pièces jointes

  • testbat(1).xlsm
    27.5 KB · Affichages: 27
Dernière édition:

job75

XLDnaute Barbatruc
Re : vba pour calculer le temps total passé par type de catégories

Bonjour, superbog, le forum,

Quelques compléments :

- le tableau source peut avoir des lignes vides

- la casse est ignorée

- le tableau des résultats peut avoir plus de 65536 lignes (Application.Transpose ne fonctionne pas).

Il faut alors faire une transposition par boucle :

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim dest As Range, t, d As Object, i&, a, b, c
Set dest = [H10] 'cellule de destination, à adapter
On Error Resume Next
t = Intersect(Range("A7:F" & Rows.Count), Me.UsedRange) 'à adapter
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 2 To UBound(t)
  If Not IsNumeric(t(i, 4)) Then t(i, 4) = 0
  d(t(i, 2)) = d(t(i, 2)) + t(i, 4)
Next
'---transposition---
a = d.keys: b = d.items
ReDim c(UBound(a), 1) 'base 0
For i = 0 To UBound(c)
  c(i, 0) = a(i): c(i, 1) = b(i)
Next
'---restitution---
Application.ScreenUpdating = False
Application.EnableEvents = False
dest.Resize(d.Count, 2) = c
dest.Resize(d.Count, 2).Sort dest, xlAscending, Header:=xlNo 'tri
dest.Offset(d.Count).Resize(Rows.Count - d.Count - dest.Row + 1, 2).ClearContents
Application.EnableEvents = True
End Sub
Fichier (2).

Bonne journée.

A+
 

Pièces jointes

  • testbat(2).xlsm
    28.6 KB · Affichages: 26
Dernière édition:

superbog

XLDnaute Occasionnel
Re : vba pour calculer le temps total passé par type de catégories

non djidji59430 le tcd n'est pas adapté car il faut nommer les plages or il y a de nombreuses feuilles concernées, je ne peux gérer autant de noms identiques
 
Dernière édition:

superbog

XLDnaute Occasionnel
Re : vba pour calculer le temps total passé par type de catégories

Merci bcp job75, comme d'hab c'est génial...

tu voudrais pas par hasard :rolleyes: jeter un oeil ici https://www.excel-downloads.com/thr...e-classeur-en-comparant-et-ajoutant.20005141/



Bonjour, superbog, le forum,

Quelques compléments :

- le tableau source peut avoir des lignes vides

- la casse est ignorée

- le tableau des résultats peut avoir plus de 65536 lignes (Application.Transpose ne fonctionne pas).

Il faut alors faire une transposition par boucle :

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim dest As Range, t, d As Object, i&, a, b, c
Set dest = [H10] 'cellule de destination, à adapter
On Error Resume Next
t = Intersect(Range("A7:F" & Rows.Count), Me.UsedRange) 'à adapter
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 2 To UBound(t)
  If Not IsNumeric(t(i, 4)) Then t(i, 4) = 0
  d(t(i, 2)) = d(t(i, 2)) + t(i, 4)
Next
'---transposition---
a = d.keys: b = d.items
ReDim c(UBound(a), 1) 'base 0
For i = 0 To UBound(c)
  c(i, 0) = a(i): c(i, 1) = b(i)
Next
'---restitution---
Application.ScreenUpdating = False
Application.EnableEvents = False
dest.Resize(d.Count, 2) = c
dest.Resize(d.Count, 2).Sort dest, xlAscending, Header:=xlNo 'tri
dest.Offset(d.Count).Resize(Rows.Count - d.Count - dest.Row + 1, 2).ClearContents
Application.EnableEvents = True
End Sub
Fichier (2).

Bonne journée.

A+
 

Discussions similaires

Réponses
7
Affichages
1 K