Excel - conditions multiples + recherche

[ABCD2008]

Bonjour à tous,

Je bataille depuis plusieurs heures avec un tableau automatique que j'aimerais créer.
Voilà, j'ai une base de données d'une 20taine de colonnes, et dans cette base, 3 colonnes m'intéressent essentiellement : CATEGORIE, COEFFICIENT, SALAIRE.

Je voudrais créer un tableau par coefficient en excluant les populations OUVRIER, APPRENTI, avec :
- le nombre de personnes dans chaque COEFFICIENT (inclus : EMPLOYE, CADRE, AG_MAITRISE, ASSIMILE_CAD)
- le salaire mini suivant le coeff et en excluant ouvrier et apprenti.

Si j'ai ces 2 colonnes, je pense que j'arriverais à me dépatouiller avec le max, la moyenne et la médiane!

Je vous joins un fichier excel.

Je vous remercie par avance de votre aide !!! =)

 

[job75]

Re : Excel - conditions multiples + recherche

Bonjour ABCD2008, chris, klin89, le forum,

je pense qu'on a vu tous les problèmes.

Oui mais on peut encore gagner un peu de temps en évitant Application.Match :

'---pour accélérer---
Set inc = CreateObject("Scripting.Dictionary")
inc.CompareMode = vbTextCompare
For i = 0 To UBound(inclu)
  inc(inclu(i)) = ""
Next
'---liste sans doublon et concaténation des salaires---
For i = 2 To UBound(t)
  If inc.exists(t(i, col1)) Then
    salaire(i, 1) = t(i, col3)
    d(t(i, col2)) = d(t(i, col2)) & " " & salaire(i, 1)
  End If
Next

Fichier (5).

Sur 84.000 lignes => 0,75 seconde

Sur 840.000 lignes => 40 secondes.

Bonne journée.

 

[chris]

Re : Excel - conditions multiples + recherche

Bonjour à tous

Job75 : belle réalisation ! Je la garde dans mon grenier à solutions .

 

[klin89]

Re : Excel - conditions multiples + recherche

Re le forum,

Autre version :
Pas tester sur 800000 lignes, pas certain que cela fonctionne

Option Explicit
Sub test()
Dim a, b(), x, w(), i As Long, n As Long, e, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    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
        For i = 2 To UBound(a, 1)
            If a(i, 1) <> "OUVRIER" And a(i, 1) <> "APPRENTI" Then
                If Not dic.exists(a(i, 2)) Then
                    n = n + 1
                    x = Filter(.Parent.Evaluate("transpose(if((" & .Columns(2).Address & _
                    "=" & Chr(34) & a(i, 2) & Chr(34) & ")*(" & .Columns(1).Address & _
                    "<>""ouvrier"")*(" & .Columns(1).Address & "<>""apprenti""),row(1:" & _
                    .Rows.Count & "),char(2)))"), Chr(2), 0)
                    x = Application.Index(.Value, Application.Transpose(x), [{3}])
                    ReDim w(1 To 2)
                    w(1) = n: w(2) = x
                    dic(a(i, 2)) = w
                End If
            End If
        Next
        For Each e In dic.keys
            w = dic(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
        Application.ScreenUpdating = False
        'restitution
        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

klin89

 

[klin89]

Re : Excel - conditions multiples + recherche

Re à tous,

Autre façon de procéder :
Sans dictionnaire mais avec le fonction Filter.
Précision : la fonction Filter ignore les "string" de longueur 0 ("")

Option Explicit

Sub test()
Dim b(), e, y, z, x As String, n As Long
    Application.ScreenUpdating = False
    With Sheets("Feuil2").Cells(1).CurrentRegion
        ReDim b(1 To .Rows.Count, 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
        x = .Columns("b").Offset(1).Resize(.Rows.Count - 1).Address
        z = Filter(.Parent.Evaluate("transpose(if(countif(offset(" & x & _
            ",0,0,row(1:" & .Rows.Count & "))," & x & ")=1," & x & ",char(2)))"), Chr(2), 0)
        'la fonction Filter ignore les "string" de longueur 0
        'donc j'ajoute la valeur "" en redimensionnant
        ReDim Preserve z(0 To UBound(z) + 1)
        For Each e In z
            y = Filter(.Parent.Evaluate("transpose(if((" & .Columns(2).Address & _
                "=" & Chr(34) & e & Chr(34) & ")*(" & .Columns(1).Address & _
                "<>""ouvrier"")*(" & .Columns(1).Address & "<>""apprenti""),row(1:" & _
                .Rows.Count & "),char(2)))"), Chr(2), 0)
            If UBound(y) > -1 Then
                y = Application.Index(.Value, Application.Transpose(y), [{3}])
                n = n + 1
                b(n, 1) = e
                b(n, 2) = Application.Count(y)
                b(n, 3) = Application.Min(y)
                b(n, 4) = Application.Max(y)
                b(n, 5) = Application.Average(y)
                b(n, 6) = Application.Median(y)
            End If
        Next
    End With
    'restitution
    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
    Application.ScreenUpdating = True
End Sub

klin89

 

[job75]

Re : Excel - conditions multiples + recherche

Bonjour klin89,

Sur 168 lignes pas de problème à condition de mettre la colonne C (Feuil2) au format Standard.

Sur 84.000 lignes :

- post #18 => 7,4 secondes mais les résultats sont faux [Edit] voir post #22

- post #19 j'ai abandonné au bout de 10 minutes.

A+

 

[job75]

Re : Excel - conditions multiples + recherche

Re,

En testant sur 840.000 lignes je viens de me rendre compte que le tableau c doit aussi avoir 2 dimensions :

'---
  ReDim c(0 To UBound(s), 0 To 0) '2 dimensions nécessaires
  For j = 0 To UBound(s)
    If IsNumeric(s(j)) Then c(j, 0) = CDbl(s(j)) 'conversion
  Next

Comme pour le tableau salaire c'est indispensable si le nombre de données (Nb) dépasse un certain montant.

65536 je pense car ça allait avec 40000 mais plus avec 80000.

Fichier (6), chris mets à jour ton grenier à solutions

A+

 

[job75]

Re : Excel - conditions multiples + recherche

Re,

C'est bien 65536 items la limite pour un tableau à une dimension :

Sub test()
Dim c()
ReDim c(1 To 65536) '1er test
'ReDim c(1 To 65537) '2ème test
MsgBox Application.CountA(c)
End Sub

C'est d'ailleurs pour cela que Application.Transpose ne fonctionne pas au-delà.

Et c'est pourquoi la macro du post #18 de klin89 (qui utilise transpose) donne des résultats faux.

Edit : curieusement MsgBox UBound(c) donne toujours le bon résultat

A+

 

[ABCD2008]

Re : Excel - conditions multiples + recherche

Vous m'avez perdue !

 

[ABCD2008]

Re : Excel - conditions multiples + recherche

Bonjour Job75, chris, klin89,

Bien que je n'arrive plus du tout à vous suivre (job75, j'ai tout de même appliqué les améliorations que tu m'as apportées), je vois que mon petit cas pratique vous fait cogiter ! =)

Merci à vous !!