Sub Importer_Periode()
Dim chemin$, fichier, F As Worksheet, a, n%, i&, deb&, fin&, dest As Range, j&, h%, P As Range, s#, Q As Range
chemin = ThisWorkbook.Path & "\" 'à adapter
fichier = "Apports YTD.xlsx"
If Dir(chemin & fichier) = "" Then MsgBox "Fichier '" & fichier & "' introuvable !", 48: Exit Sub
Set F = ActiveSheet
a = Array("DECHET", "ENTIER")
Application.ScreenUpdating = False
F.[C42:C51,D42:E52,K42:K51,L42:M52,S42:S51,T42:T52].ClearContents 'RAZ
On Error Resume Next 'si le fichier n'est pas ouvert
Workbooks(fichier).Close False 'si le fichier est ouvert on le ferme
On Error GoTo 0
With Workbooks.Open(chemin & fichier).Sheets(1) 'ouverture du fichier source
'---préparation---
.Cells.UnMerge 'défusionne les cellules pour permettre les tris
For n = 0 To UBound(a)
i = Application.Match(a(n), .Columns(3), 0)
If n = 0 Then deb = i Else If i < deb Then deb = i 'détermine la ligne du début
Next n
With .Columns("A:C")
.Replace "*Total", "#N/A", xlWhole
.SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete 'supprime les lignes des Total
End With
fin = .Cells(.Rows.Count, 4).End(xlUp).Row 'détermine la ligne de fin
For i = deb + 1 To fin
If .Cells(i, 3) = "" Then .Cells(i, 3) = .Cells(i - 1, 3) 'remplit les cellules vides en colonne C
Next i
.Rows(deb & ":" & fin).Sort .Columns(3), Header:=xlNo 'tri pour regrouper les DECHET et les ENTIER
'---1er et 2ème tableaux---
For n = 0 To UBound(a)
Set dest = IIf(n, F.[C42], F.[K42]) '1ère cellule de destination
i = Application.Match(a(n), .Columns(3), 0) 'EQUIV
j = i + Application.CountIf(.Columns(3), a(n)) - 1 'NB.SI
With .Rows(i & ":" & j)
.Sort .Columns(4), Header:=xlNo 'tri alphabétique
For i = 2 To .Rows.Count
If UCase(.Cells(i - 1, 4)) = UCase(.Cells(i, 4)) Then
h = Application.CountIf(.Columns(4), .Cells(i, 4)) '3 sur l'exemple
j = i + h - 2 'dernière ligne du même fournisseur
Set P = .Cells(i - 1, 6).Resize(h)
s = Application.Sum(P) 'somme sur F
If s Then
Set Q = .Cells(i - 1, 16).Resize(h)
.Cells(j, 16) = Application.SumProduct(P, Q) / s 'moyenne pondérée sur P
End If
.Cells(j, 6) = s 'consolidation
.Rows(i - 1).Resize(h - 1).ClearContents 'effacement
i = j
End If
Next i
.Sort .Columns(6), xlDescending, Header:=xlNo 'tri décroissant sur la colonne F
h = IIf(.Rows.Count > 10, 10, .Rows.Count)
dest.Resize(h) = .Columns(4).Resize(h).Value 'D
dest(1, 2).Resize(h) = .Columns(6).Resize(h).Value 'F
dest(1, 3).Resize(h) = .Columns(16).Resize(h).Value 'P
If .Rows.Count > 10 Then 'Autres
Set P = .Columns(6).Offset(10).Resize(.Rows.Count - 10)
dest(11, 2) = Application.Sum(P) 'somme sur F
If dest(11, 2) Then
Set Q = .Columns(16).Offset(10).Resize(.Rows.Count - 10)
dest(11, 3) = Application.SumProduct(P, Q) / dest(11, 2) 'moyenne pondérée sur P
End If
End If
End With
Next n
'---3ème tableau---
Set dest = F.[S42] '1ère cellule de destination
With .Rows(deb & ":" & fin)
.Sort .Columns(4), Header:=xlNo 'tri alphabétique de l'ensemble des tableaux
For i = 2 To .Rows.Count
If UCase(.Cells(i - 1, 4)) = UCase(.Cells(i, 4)) Then
.Cells(i, 6) = .Cells(i, 6) + .Cells(i - 1, 6) 'consolidation
.Rows(i - 1).ClearContents 'effacement
End If
Next i
.Sort .Columns(6), xlDescending, Header:=xlNo 'tri décroissant sur la colonne F
h = IIf(.Rows.Count > 10, 10, .Rows.Count)
dest.Resize(h) = .Columns(4).Resize(h).Value 'D
dest(1, 2).Resize(h) = .Columns(6).Resize(h).Value 'F
If .Rows.Count > 10 Then 'Autres
Set P = .Columns(6).Offset(10).Resize(.Rows.Count - 10)
dest(11, 2) = Application.Sum(P) 'somme sur F
End If
End With
'---fermeture du fichier source---
.Parent.Close False
End With
End Sub
