Discussion :

[QGRdev]

Bonjour,

J'ai actuellement un tableau1 avec les champs suivants: "Personne", "Date", "Nb1", "Nb2", "Nb3". J'ai également un tableau2 avec les champs: "Personne", "Groupe".

Je dispose déjà de toutes les informations du tableau1 (et il évolura en fonction du temps en ayant de plus en plus de données). Mon but est de pouvoir rajouter manuellement des personnes dans un groupe (A, B ou C).
Lorsque l'on clique sur le bouton "OK", j'aimerai qu'un code VBA fasse l'algorithme suivant:

• Pour chaque date, faire la moyenne des membres du groupe pour Nb1, Nb2 et Nb3.
• Rajouter la ligne de résultat dans le tableau.

Afin d'être plus clair, je joins un document Excel. La feuille "Principale" montre mes données d'origine, le feuille "Résultat, montre le résultat que j'aimerai obtenir.

Cordialement.

[PMO2017]

Bonjour,

Une piste avec le code suivant à copier dans un module standard

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
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
'### Constantes à adapter ###
Const FIRSTCELL_TABLEAU_1 As String = "A1"  '1ère cellule du Tableau1
Const FIRSTCELL_TABLEAU_2 As String = "L1"  '1ère cellule du Tableau2
'############################
 
Type structGroupes
  Name As String
  Personnes() As String
  PersCount As Long
End Type
Type structPlagesDates
  Deb As Long
  Fin As Long
End Type
 
Sub ObtenirGroupes()
Dim S As Worksheet
Dim R1 As Range
Dim R2 As Range
Dim R As Range
Dim var1
Dim var2
Dim var
Dim g&
Dim h&
Dim i&
Dim j&
Dim k&
Dim cpt&
Dim bool As Boolean
Dim Groupes() As structGroupes
Dim PlagesDates() As structPlagesDates
Dim T()
Dim tempo()
'---
Set S = ActiveSheet
Set R1 = S.Range(FIRSTCELL_TABLEAU_1).CurrentRegion
var1 = R1
Set R2 = S.Range(FIRSTCELL_TABLEAU_2).CurrentRegion
var2 = R2
If Not IsArray(var1) Or Not IsArray(var2) Then Exit Sub
'---
For i& = 2 To UBound(var2, 1)
  If var2(i&, 2) <> "" Then
    bool = True
    Exit For
  End If
Next i&
If Not bool Then
  MsgBox "Aucun groupe n'a été trouvé dans le Tableau2"
  Exit Sub
End If
'### Détermination des groupes ###
'--- Noms ---
For i& = 2 To UBound(var2, 1)
  If var2(i&, 2) <> "" Then
    bool = False
    On Error Resume Next
    j& = UBound(Groupes)
    If Err <> 0 Then
      ReDim Preserve Groupes(1 To 1)
      Groupes(1).Name = var2(i&, 2)
      Err.Clear
    Else
      For k& = 1 To UBound(Groupes)
        If Groupes(k&).Name = var2(i&, 2) Then
          bool = True
          Exit For
        End If
      Next k&
      If Not bool Then
        ReDim Preserve Groupes(1 To UBound(Groupes) + 1)
        Groupes(UBound(Groupes)).Name = var2(i&, 2)
      End If
    End If
  End If
Next i&
On Error GoTo 0
'--- Personnes (Nom et nombre) ---
For i& = 1 To UBound(Groupes)
  For k& = 2 To UBound(var2, 1)
    If var2(k&, 2) = Groupes(i&).Name Then
      j& = Groupes(i&).PersCount + 1
      ReDim Preserve Groupes(i&).Personnes(1 To j&)
      Groupes(i&).Personnes(j&) = var2(k&, 1)
      Groupes(i&).PersCount = j&
    End If
  Next k&
Next i&
'### Les différentes PlagesDates (ligne de début et ligne de fin) ###
For i& = 2 To UBound(var1, 1)
  If var1(i&, 2) <> var1(i& - 1, 2) Then
    cpt& = cpt& + 1
    ReDim Preserve PlagesDates(1 To cpt&)
    PlagesDates(cpt&).Deb = i&
    If cpt& > 1 Then PlagesDates(cpt& - 1).Fin = i& - 1
  End If
Next i&
PlagesDates(cpt&).Fin = i& - 1
'####################################################################
'--- Algorithme de calcul ---
bool = False
cpt& = 0
For h& = 1 To UBound(PlagesDates)
  Set R = S.Range(S.Cells(PlagesDates(h&).Deb, 1), S.Cells(PlagesDates(h&).Fin, UBound(var1, 2)))
  var = R
  For k& = 1 To UBound(Groupes)
    ReDim tempo(3 To UBound(var, 2))
    For g& = 1 To Groupes(k&).PersCount
      For i& = 1 To UBound(var, 1)
        For j& = 3 To UBound(var, 2)
          If Groupes(k&).Personnes(g&) = var(i&, 1) Then
            tempo(j&) = tempo(j&) + var(i&, j&)
            bool = True
          End If
        Next j&
      Next i&
    Next g&
    If bool Then
      cpt& = cpt& + 1
      ReDim Preserve T(1 To UBound(var, 2), 1 To cpt&)
      T(1, cpt&) = Groupes(k&).Name
      T(2, cpt&) = var(1, 2)
      For j& = 3 To UBound(var, 2)
        T(j&, cpt&) = tempo(j&) / Groupes(k&).PersCount
      Next j&
      Erase tempo
      bool = False
    End If
  Next k&
Next h&
'--- Inscription des résultats dans une nouvelle feuille ---
If IsArray(T) Then
  Sheets.Add after:=S
  Set S = ActiveSheet
  Set R = S.Range(S.Cells(1, 1), S.Cells(UBound(T, 2), UBound(T, 1)))
  R = Application.WorksheetFunction.Transpose(T)
End If
End Sub

Le Tableau1 doit commencer en A1, comporter une ligne de titres et être trié par date.
Le Tabeau2 doit commencer en L1 et comporter une ligne de titres.
Sélectionnez la feuille concernée et lancez la macro "ObtenirGroupes".
Le résultat s'affiche dans une nouvelle feuille et peut être copié puis collé à l'endroit de votre choix.
(pour plus de facilité, consultez la pièce jointe).

Cordialement.