Option Explicit
Sub F_Par_Client()
With Application: .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False: End With
Dim fFourn As Worksheet, fClients As Worksheet, tClients
Dim tabfin, i%, Annee As String
Dim start As Single
start = Timer
Set fFourn = Sheets("Fourn Par Client")
Set fClients = Sheets("Clients")
Set tabfin = fFourn.ListObjects("Tableau16")
tClients = fClients.Range("B3:P" & fClients.Range("B" & Rows.Count).End(xlUp).Row)
Annee = fFourn.Range("B2")
'Effacement du 1er tableau
For i = Range("B" & Rows.Count).End(xlUp).Row - 4 To 1 Step -1
With tabfin
.ListRows(i).Range.Delete
End With
Next i
Dim fMvtStock As Worksheet, fVentes As Worksheet, tMvtStock, tCommandes, a(), b()
Dim j%, n%, m%, k%
Set fMvtStock = Sheets("Mvts Stock")
tMvtStock = fMvtStock.Range("B3:V" & fMvtStock.Range("B" & Rows.Count).End(xlUp).Row)
'MsgBox "Durée du traitement: " & Timer - start & " secondes"
Dim dcli, dfourn
Set dcli = CreateObject("Scripting.Dictionary")
Set dfourn = CreateObject("Scripting.Dictionary")
dcli.CompareMode = vbTextCompare
dfourn.CompareMode = vbTextCompare
'Dico pour les clients
For i = 1 To UBound(tMvtStock)
For j = 1 To UBound(tClients)
If tMvtStock(i, 6) = tClients(j, 1) And tClients(j, 15) = "" _
And Year(tMvtStock(i, 1)) >= Annee Then
dcli(tMvtStock(i, 6)) = tMvtStock(i, 6)
End If
Next j
Next i
'Dico pour les fournisseurs
For i = 1 To UBound(tMvtStock)
For j = 1 To UBound(tClients)
If tMvtStock(i, 6) = tClients(j, 1) And tClients(j, 15) = "" _
And Year(tMvtStock(i, 1)) >= Annee Then
dfourn(tMvtStock(i, 5)) = tMvtStock(i, 5)
End If
Next j
Next i
ReDim a(1 To UBound(tMvtStock), 1 To 6)
n = 1
For Each c In dcli.keys
'Debug.Print d.Count
'Debug.Print d(c)
a(n, 1) = c
n = n + 1
Next c
ReDim b(1 To UBound(tMvtStock), 1 To 6)
m = 1
For Each c In dfourn.keys
'Debug.Print d.Count
'Debug.Print d(c)
b(m, 1) = c
m = m + 1
Next c
ReDim tFinal(1 To UBound(tMvtStock), 1 To 16)
Dim pool As Boolean
n = 1
For Each c In dcli.keys
For Each cc In dfourn.keys
pool = False
For i = 1 To UBound(tMvtStock)
If tMvtStock(i, 6) = c And tMvtStock(i, 5) = cc Then
tFinal(n, 1) = tMvtStock(i, 6)
tFinal(n, 11) = tMvtStock(i, 5)
For j = 1 To UBound(tClients)
If tMvtStock(i, 6) = tClients(j, 1) Then
For k = 2 To 3
tFinal(n, k) = tClients(j, k)
Next k
For k = 4 To 8
tFinal(n, k) = tClients(j, k + 2)
Next k
For k = 9 To 10
tFinal(n, k) = tClients(j, k + 3)
Next k
End If
Next j
pool = True
End If
Next i
If pool Then n = n + 1
Next cc
Next c
'PARTIE POSANT PROBLEME
'PARTIE POSANT PROBLEME
If fFourn.Range("F1") = "GO" Then
Dim an1 As String, an2 As String, an3 As String, an4 As String
an1 = Range("M3")
an2 = Range("N3")
an3 = Range("O3")
an4 = Range("P3")
an5 = Range("Q3")
Dim somme As Double, somme2 As Double, somme3 As Double, somme4 As Double, somme5 As Double
For i = 1 To UBound(tFinal)
For j = 1 To UBound(tMvtStock)
If tFinal(i, 1) = tMvtStock(j, 6) And tFinal(i, 11) = tMvtStock(j, 5) _
And Year(tMvtStock(j, 1)) = an1 Then
somme = somme + Round(tMvtStock(j, 21), 2)
End If
If tFinal(i, 1) = tMvtStock(j, 6) And tFinal(i, 11) = tMvtStock(j, 5) _
And Year(tMvtStock(j, 1)) = an2 Then
somme2 = somme2 + Round(tMvtStock(j, 21), 2)
End If
If tFinal(i, 1) = tMvtStock(j, 6) And tFinal(i, 11) = tMvtStock(j, 5) _
And Year(tMvtStock(j, 1)) = an3 Then
somme3 = somme3 + Round(tMvtStock(j, 21), 2)
End If
If tFinal(i, 1) = tMvtStock(j, 6) And tFinal(i, 11) = tMvtStock(j, 5) _
And Year(tMvtStock(j, 1)) = an4 Then
somme4 = somme4 + Round(tMvtStock(j, 21), 2)
End If
If tFinal(i, 1) = tMvtStock(j, 6) And tFinal(i, 11) = tMvtStock(j, 5) _
And Year(tMvtStock(j, 1)) = an5 Then
somme5 = somme5 + Round(tMvtStock(j, 21), 2)
End If
Next j
tFinal(i, 12) = somme
tFinal(i, 13) = somme2
tFinal(i, 14) = somme3
tFinal(i, 15) = somme4
tFinal(i, 16) = somme5
somme = 0
somme2 = 0
somme3 = 0
somme4 = 0
somme5 = 0
Next i
End If
fFourn.Range("B5").Resize(n - 1, 16) = tFinal
'Mise en forme de la cellule L5
Range("L6").Copy
Range("L5").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Set fFourn = Nothing
Set fClients = Nothing
Set tabfin = Nothing
Set fMvtStock = Nothing
Set fVentes = Nothing
Set dcli = Nothing
Set dfourn = Nothing
MsgBox "Durée du traitement: " & Timer - start & " secondes"
With Application: .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True: End With
End Sub