Formule Max à optimiser ou somme Max

Bonsoir le forum,

Dans un classeur, j'ai une base de données en feuil1, que j'alimente une fois par semaine. Des références apparaissent donc plusieurs fois dans cette même feuille.

J'ai demandé au forum une formule max pour faire un Pareto, et le problème est que la formule Max ne m'afficher le Max d'une ref alors que dit dit plus haut elle apparaît plusieurs fois.

C'est pourquoi je souhaiterai une fonction somme Max si possible?

En vous remerciant d'avance.

Cordialement,

Max


Max6546 a écrit :

Bonsoir le forum,

Dans un classeur, j'ai une base de données en feuil1, que j'alimente une fois par semaine. Des références apparaissent donc plusieurs fois dans cette même feuille.

J'ai demandé au forum une formule max pour faire un Pareto, et le problème est que la formule Max ne m'afficher le Max d'une ref alors que dit dit plus haut elle apparaît plusieurs fois.

C'est pourquoi je souhaiterai une fonction somme Max si possible?

En vous remerciant d'avance.

Cordialement,

Max

Avec le fichier ça sera beaucoup mieux

53pareto.xlsx (115.65 Ko)

Bonjour

Je vous conseil un Tableau croisée dynamique.

18pareto.xlsx (184.92 Ko)

Bonjour

Ou une colonne intermédiaire

Cordialement

24max.zip (90.45 Ko)

Bonsoir à tous,

Si j'ai bien compris.

Restitution en Feuil2.

Option Explicit

Sub Pic_Article()
Dim a, i As Long, j As Long, txt As String, n As Long
    Application.ScreenUpdating = False
    With Sheets("Feuil1").Range("A1").CurrentRegion
        a = Application.Index(.Value, Evaluate("row(1:" & _
                                               .Rows.Count & ")"), Array(3, 6, 10))
    End With
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            txt = a(i, 1)
            If Not .exists(txt) Then
                n = n + 1
                .Item(txt) = n
                For j = 1 To UBound(a, 2)
                    a(n, j) = a(i, j)
                Next
            Else
                If a(.Item(txt), 3) <= a(i, 3) Then
                    For j = 1 To UBound(a, 2)
                        a(.Item(txt), j) = a(i, j)
                    Next
                End If
            End If
        Next
    End With
    With Sheets("Feuil2").Range("A1")
        .CurrentRegion.Clear
        .Cells(1).Resize(n, UBound(a, 2)).Value = a
        With .CurrentRegion
            .Font.Name = "calibri"
            .Font.Size = 10
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThin
            .BorderAround Weight:=xlThin
            With .Rows(1)
                .Font.Size = 11
                .Interior.ColorIndex = 38
                .BorderAround Weight:=xlThin
            End With
            .Columns.AutoFit
            .Sort key1:=.Cells(3), order1:=2, Header:=1
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Bonjour,

Pour le fun et Excel 2010 et +.

Cdlt.

Jean-Eric a écrit :

Bonjour,

Pour le fun et Excel 2010 et +.

Cdlt.

Super l'idée du TCD, dommage qu'on aie pas 2010 au travail

Re,

Alors, sans les segments propres à Excel 2010 et +

A adapter.

Cdlt.

Klin89 a écrit :

Bonsoir à tous,

Si j'ai bien compris.

Restitution en Feuil2.

Option Explicit

Sub Pic_Article()
Dim a, i As Long, j As Long, txt As String, n As Long
    Application.ScreenUpdating = False
    With Sheets("Feuil1").Range("A1").CurrentRegion
        a = Application.Index(.Value, Evaluate("row(1:" & _
                                               .Rows.Count & ")"), Array(3, 6, 10))
    End With
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            txt = a(i, 1)
            If Not .exists(txt) Then
                n = n + 1
                .Item(txt) = n
                For j = 1 To UBound(a, 2)
                    a(n, j) = a(i, j)
                Next
            Else
                If a(.Item(txt), 3) <= a(i, 3) Then
                    For j = 1 To UBound(a, 2)
                        a(.Item(txt), j) = a(i, j)
                    Next
                End If
            End If
        Next
    End With
    With Sheets("Feuil2").Range("A1")
        .CurrentRegion.Clear
        .Cells(1).Resize(n, UBound(a, 2)).Value = a
        With .CurrentRegion
            .Font.Name = "calibri"
            .Font.Size = 10
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThin
            .BorderAround Weight:=xlThin
            With .Rows(1)
                .Font.Size = 11
                .Interior.ColorIndex = 38
                .BorderAround Weight:=xlThin
            End With
            .Columns.AutoFit
            .Sort key1:=.Cells(3), order1:=2, Header:=1
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Bonsoir Klin,

Merci pour ta macro, mais le résultat n'est pas celui attendu. Il ne prend en compte le match que d'une ref, alors que la même ref peut plusieurs fois (chaque semaine).

Cordialement,

Max


Jean-Eric a écrit :

Re,

Alors, sans les segments propres à Excel 2010 et +

A adapter.

Cdlt.

Merci Jean-Eric,

J'ai beau me casser la tête avec des formules, je pense que les TCD restent une des meilleures solutions.

J'ai toujours eu du mal par contre pour les filtres (décroissant ou croissant) sur les TCD, et je pense que je viens de comprendre pourquoi: je mettrai trop de champs dans les lignes du rapport.

Pourquoi avoir fait une rechercheV concernant la désignation article? est-ce dû mon problème expliqué ci-dessus?

Merci

Max

Re,

J'ai utilisé cet artifice pour la représentation graphique.

Essaie d'ajouter la désignation de l'article dans le TCD (étiquettes de lignes).

Cdt.

Amadéus a écrit :

Bonjour

Ou une colonne intermédiaire

Cordialement

Amadeus,

je n'arrive pas à ouvrir le le fichier malgré Winzip téléchargé.

Cdlt

max

Bonjour

je n'arrive pas à ouvrir le le fichier malgré Winzip téléchargé.

Pour une fois, nous allons enfreindre la règle des 300Ko.

Cordialement

22pareto.zip (92.06 Ko)
Amadéus a écrit :

Bonjour

je n'arrive pas à ouvrir le le fichier malgré Winzip téléchargé.

Pour une fois, nous allons enfreindre la règle des 300Ko.

Cordialement

Parfait,

Merci Amadeus

Cordialement,

Max

Re Max6546,

J'ai pigé

Restitution en Feuil2.

Option Explicit

Sub Pic_Article()
Dim a, i As Long, j As Long, txt As String, n As Long
    Application.ScreenUpdating = False
    With Sheets("Feuil1").Range("A1").CurrentRegion
        a = Application.Index(.Value, Evaluate("row(1:" & _
                                               .Rows.Count & ")"), Array(3, 6, 10))
    End With
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            txt = a(i, 1)
            If Not .exists(txt) Then
                n = n + 1
                .Item(txt) = n
                For j = 1 To UBound(a, 2)
                    a(n, j) = a(i, j)
                Next
            Else
                If txt <> "Article" Then
                    a(.Item(txt), 3) = a(.Item(txt), 3) + a(i, 3)
                End If
            End If
        Next
    End With
    With Sheets("Feuil2").Range("A1")
        .CurrentRegion.Clear
        .Cells(1).Resize(n, UBound(a, 2)).Value = a
        With .CurrentRegion
            .Font.Name = "calibri"
            .Font.Size = 10
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThin
            .BorderAround Weight:=xlThin
            With .Rows(1)
                .Font.Size = 11
                .Interior.ColorIndex = 38
                .BorderAround Weight:=xlThin
            End With
            .Columns.AutoFit
            .Sort key1:=.Cells(3), order1:=2, Header:=1
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Klin89 a écrit :

Re Max6546,

J'ai pigé

Restitution en Feuil2.

Option Explicit

Sub Pic_Article()
Dim a, i As Long, j As Long, txt As String, n As Long
    Application.ScreenUpdating = False
    With Sheets("Feuil1").Range("A1").CurrentRegion
        a = Application.Index(.Value, Evaluate("row(1:" & _
                                               .Rows.Count & ")"), Array(3, 6, 10))
    End With
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            txt = a(i, 1)
            If Not .exists(txt) Then
                n = n + 1
                .Item(txt) = n
                For j = 1 To UBound(a, 2)
                    a(n, j) = a(i, j)
                Next
            Else
                If txt <> "Article" Then
                    a(.Item(txt), 3) = a(.Item(txt), 3) + a(i, 3)
                End If
            End If
        Next
    End With
    With Sheets("Feuil2").Range("A1")
        .CurrentRegion.Clear
        .Cells(1).Resize(n, UBound(a, 2)).Value = a
        With .CurrentRegion
            .Font.Name = "calibri"
            .Font.Size = 10
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThin
            .BorderAround Weight:=xlThin
            With .Rows(1)
                .Font.Size = 11
                .Interior.ColorIndex = 38
                .BorderAround Weight:=xlThin
            End With
            .Columns.AutoFit
            .Sort key1:=.Cells(3), order1:=2, Header:=1
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Merci Klin89,

Rechercher des sujets similaires à "formule max optimiser somme"