Private Sub Worksheet_Activate()
Dim col1%, col2%, col3%, inclu, t, salaire()
Dim d As Object, i&, n&, a, b, s, c, j&
col1 = 1: col2 = 2: col3 = 3 'n° des colonnes, à adapter
inclu = Array("EMPLOYE", "CADRE", "AG_MAITRISE", "ASSIMILE_CAD")
t = Feuil2.UsedRange 'CodeName de la feuille
ReDim salaire(UBound(t))
Set d = CreateObject("Scripting.Dictionary")
'---liste sans doublon et concaténation des salaires---
For i = 2 To UBound(t)
If IsNumeric(Application.Match(t(i, col1), inclu, 0)) Then
salaire(i) = t(i, col3)
d(t(i, col2)) = d(t(i, col2)) & " " & salaire(i)
End If
Next
n = d.Count
Application.ScreenUpdating = False
Range("A2:F" & Rows.Count).Delete xlUp 'RAZ
If n = 0 Then Exit Sub
'---tableaux VBA---
a = d.keys: b = d.items
ReDim t(1 To n, 1 To 6)
For i = 1 To n
s = Split(Mid(b(i - 1), 2))
ReDim c(UBound(s))
For j = 0 To UBound(s)
c(j) = CDbl(s(j)) 'conversion
Next
t(i, 1) = a(i - 1)
With Application
t(i, 2) = .Count(c): t(i, 3) = .Min(c): t(i, 4) = .Max(c)
t(i, 5) = .Average(c): t(i, 6) = .Median(c)
End With
Next
'---restitution---
With [A2].Resize(n, 6)
.Value = t
.Sort .Columns(1), xlAscending, Header:=xlNo 'tri
.Cells(n + 2, 1) = "Total"
.Cells(n + 2, 1).Font.Bold = True 'gras
.Cells(n + 2, 2) = Application.Count(salaire)
.Cells(n + 2, 3) = Application.Min(salaire)
.Cells(n + 2, 4) = Application.Max(salaire)
.Cells(n + 2, 5) = Application.Average(salaire)
.Cells(n + 2, 6) = Application.Median(salaire)
End With
End Sub
If IsNumeric(s(j)) Then c(j) = CDbl(s(j)) 'conversion
col1 = 14: col2 = 15: col3 = 20 'n° des colonnes, à adapter
=SI(OU([@CATEGORIE]="OUVRIER";[@CATEGORIE]="APPRENTI");"exclu du calcul";SIERREUR(MEDIANE(SI(([COEFFICIENT]=[@COEFFICIENT])*([CATEGORIE]<>"OUVRIER")*([CATEGORIE]<>"APPRENTI");[Salaire]));"exclu du calcul"))
J'ai eu un soucis pour le Total en dessous, mais j'ai appliqué le conseil de job75 sur le fait d'avoir des nombres (ma colonne salaire était en mode comptabilité) et du coup, tout fonctionne !
t = Feuil2.UsedRange.Value2 'CodeName de la feuille
ReDim salaire(1 To UBound(t), 1 To 1)
Private Sub Worksheet_Activate()
Dim col1%, col2%, col3%, inclu, t, salaire()
Dim d As Object, i&, n&, a, b, s, c, j&
col1 = 1: col2 = 2: col3 = 3 'n° des colonnes, à adapter
inclu = Array("EMPLOYE", "CADRE", "AG_MAITRISE", "ASSIMILE_CAD")
t = Feuil2.UsedRange.Value2 'CodeName de la feuille
ReDim salaire(1 To UBound(t), 1 To 1)
Set d = CreateObject("Scripting.Dictionary")
'---liste sans doublon et concaténation des salaires---
For i = 2 To UBound(t)
If IsNumeric(Application.Match(t(i, col1), inclu, 0)) Then
salaire(i, 1) = t(i, col3)
d(t(i, col2)) = d(t(i, col2)) & " " & salaire(i, 1)
End If
Next
n = d.Count
Application.ScreenUpdating = False
Range("A2:F" & Rows.Count).Delete xlUp 'RAZ
If n = 0 Then Exit Sub
'---tableaux VBA---
a = d.keys: b = d.items
ReDim t(1 To n, 1 To 6)
For i = 1 To n
s = Split(Mid(b(i - 1), 2))
ReDim c(UBound(s))
For j = 0 To UBound(s)
If IsNumeric(s(j)) Then c(j) = CDbl(s(j)) 'conversion
Next
t(i, 1) = a(i - 1)
With Application
t(i, 2) = .Count(c): t(i, 3) = .Min(c): t(i, 4) = .Max(c)
t(i, 5) = .Average(c): t(i, 6) = .Median(c)
End With
Next
'---restitution---
With [A2].Resize(n, 6)
.Value = t
.Sort .Columns(1), xlAscending, Header:=xlNo 'tri
.Cells(n + 2, 1) = "Total"
.Cells(n + 2, 1).Font.Bold = True 'gras
.Cells(n + 2, 2) = Application.Count(salaire)
.Cells(n + 2, 3) = Application.Min(salaire)
.Cells(n + 2, 4) = Application.Max(salaire)
.Cells(n + 2, 5) = Application.Average(salaire)
.Cells(n + 2, 6) = Application.Median(salaire)
End With
End Sub
Option Explicit
Sub test()
Dim a, b(), x(), w(), i As Long, n As Long, e
With Sheets("Feuil2").Range("a1").CurrentRegion
a = .Value
ReDim b(1 To UBound(a, 1), 1 To 6)
b(1, 1) = "Coefficient": b(1, 2) = "Nbre": b(1, 3) = "Mini"
b(1, 4) = "Maxi": b(1, 5) = "Moyenne": b(1, 6) = "Médiane"
n = 1
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
If a(i, 1) <> "OUVRIER" And a(i, 1) <> "APPRENTI" Then
If Not .exists(a(i, 2)) Then
n = n + 1
ReDim w(1 To 2)
ReDim x(1 To 1): x(1) = a(i, 3)
w(1) = n: w(2) = x
.Item(a(i, 2)) = w
Else
w = .Item(a(i, 2))
x = w(2)
ReDim Preserve x(1 To UBound(x) + 1)
x(UBound(x)) = a(i, 3)
w(2) = x
.Item(a(i, 2)) = w
End If
End If
Next
For Each e In .keys
w = .Item(e)
b(w(1), 1) = e
b(w(1), 2) = Application.Count(w(2))
b(w(1), 3) = Application.Min(w(2))
b(w(1), 4) = Application.Max(w(2))
b(w(1), 5) = Application.Average(w(2))
b(w(1), 6) = Application.Median(w(2))
Next
End With
Application.ScreenUpdating = False
With Sheets("Feuil3").Range("a1")
.CurrentRegion.Clear
.Resize(n, 6).Value = b
With .CurrentRegion
.Sort .Columns(1), xlAscending, Header:=xlYes
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Columns(5).NumberFormat = "0"
With .Rows(1)
.Interior.ColorIndex = 44
.BorderAround Weight:=xlThin
.HorizontalAlignment = xlCenter
End With
End With
End With
End With
Application.ScreenUpdating = True
End Sub