Microsoft 365 Calculer et classer les factures en fonction de leur importance

Sub ParetoFactures()

    Dim ws As Worksheet
    Dim lastRow As Long
    Dim totalDebit As Double
    Dim i As Long
    Dim cumul As Double
    Dim seuil As Double
   
    Set ws = ThisWorkbook.Sheets("Factures") ' Adapter le nom de la feuille
   
    ' Paramètres
        'seuil = 0.3   ' 30% (modifiable)
        seuil = ws.Cells(4, 3)
   
    ' Dernière ligne
    lastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
   
    ' Calcul total
    totalDebit = Application.WorksheetFunction.Sum(ws.Range("I7:I" & lastRow))
    ws.Range("B4").Value = totalDebit

    ' Nettoyage couleurs avant nouvelle exécution
    ws.Range("D8:L" & lastRow).Interior.Color = xlNone
   
    ' Trier les factures par montant décroissant
    ws.Sort.SortFields.Clear
    ws.Sort.SortFields.Add Key:=ws.Range("I7:I" & lastRow), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ws.Sort
        .SetRange ws.Range("D7:L" & lastRow)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
   
    ' Boucle pour calculer % poids et % cumulé
    cumul = 0
    For i = 8 To lastRow
        ws.Cells(i, "J").Value = ws.Cells(i, "I").Value / totalDebit
        cumul = cumul + ws.Cells(i, "J").Value
        ws.Cells(i, "L").Value = cumul
       
        ' Colorier si dans les X% premiers
        If cumul <= seuil Then
            ws.Range("D" & i & ":L" & i).Interior.Color = RGB(255, 255, 0) ' Jaune
        Else
            ws.Rows(i).Interior.Color = xlNone
        End If
    Next i
   
    MsgBox "Analyse Pareto terminée - " & Format(seuil * 100, "0") & "% des factures sélectionnées."
   
End Sub

Private Sub WorkSheet_Activate()
Dim maxi#, tablo, i&, s#
maxi = [TotalDébit] * [Poids]
Application.ScreenUpdating = False
Cells.Delete 'RAZ
With UsedRange: End With 'actualise le UsedRange
With [TS_Factures].ListObject.Range 'tableau structuré
    .AutoFilter: .AutoFilter 'affiche tout
    .Copy [A1]
End With
With [A1].CurrentRegion
    .Sort .Columns(6), xlDescending, Header:=xlYes 'tri décroissant sur les montants
    tablo = .Columns(6).Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
    For i = 2 To UBound(tablo)
        If IsNumeric(tablo(i, 1)) Then s = s + CDbl(tablo(i, 1))
        If s > maxi Then Exit For
    Next
    If i < .Rows.Count Then .Rows(i + 1).Resize(.Rows.Count - i).Delete xlUp
End With
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub