Option Explicit
Sub Bordero()
Dim Dico, xCell As Range, i As Long, j As Long
Dim Source(), Indice As Long, NewDico, Mazone As Range
Dim DateInf As Date, DateSup As Date, NbrJours As Long
Application.ScreenUpdating = False
'création dico principal
Set Dico = CreateObject("Scripting.Dictionary")
'Récup Dates
DateInf = Range("Date_Inf"): DateSup = Range("Date_Sup")
'Recup Nonbre de jours
NbrJours = Range("Nbr_Jours")
'vérification
If NbrJours <= 0 Or NbrJours > 17 Then
MsgBox "Le nombre de jours est soit négatif soit supérieur à 17 : Abandon!"
Exit Sub
End If
'passage des données Mvts dans le tableau Source
With Sheets("Mvts")
Source = .Range(.Range("A3"), .Cells(.Rows.Count, "a").End(xlUp)).Resize(, 3).Value
End With
'Récupération dans le dico principal des noms des médoc en stock
With Sheets("Stock")
For Each xCell In .Range("b2", .Range("b2").End(xlDown))
If Not Dico.Exists(xCell.Value) Then
'création d'un dico secondaire de clef 1 à Nbrjours et
'chaque valeur (de 1 à Nbrejours) initialisée à zéro
Set NewDico = CreateObject("Scripting.Dictionary")
For j = 1 To NbrJours: NewDico.Add j, 0: Next j
'On ajoute au dico principal le dico secondaire avec
'la clef = le nom du médoc
Dico.Add xCell.Value, NewDico
End If
Next xCell
End With
'On recommence la même chose avec les médoc de la feuille Mvts
For i = LBound(Source) To UBound(Source)
If Not Dico.Exists(Source(i, 2)) Then
Set NewDico = CreateObject("Scripting.Dictionary")
For j = 1 To NbrJours: NewDico.Add j, 0: Next j
Dico.Add Source(i, 2), NewDico
End If
Next i
'on somme par jour et par médoc les quantités sorties
For i = LBound(Source) To UBound(Source)
Indice = Source(i, 1) - DateInf + 1
If Indice >= 1 And Indice <= NbrJours Then
Dico(Source(i, 2))(Indice) = Dico(Source(i, 2))(Indice) + Source(i, 3)
End If
Next i
'Effacement du bordereau
With Sheets("Bordereau")
.Range("A14:U" & Rows.Count).Clear
'écriture des résultat
Dim Clefs
Clefs = Dico.keys
Set xCell = .Cells(14, "a")
For i = 0 To Dico.Count - 1
xCell = i + 1
'Nom du médoc (dico principal)
xCell.Offset(, 1) = Clefs(i)
'Item du dico secondaire de clef le nom du médoc
xCell.Offset(, 2).Resize(, NbrJours).Value = Dico(Clefs(i)).items
Set xCell = xCell.Offset(1)
Next i
'Formule colonne T
.Range("T14:T" & .Range("A14").End(xlDown).Row).FormulaR1C1 = _
"=IF(SUM(RC[-17]:RC[-1])=0,"""",SUM(RC[-17]:RC[-1]))"
'Formule colonne U
.Range("U14:U" & .Range("A14").End(xlDown).Row).FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC2,Stock!R1C2:R1000C3,2,FALSE)),""""," & _
"IF( VLOOKUP(RC2,Stock!R1C2:R1000C3,2,FALSE)=0,"""", " & _
"VLOOKUP(RC2,Stock!R1C2:R1000C3,2,FALSE)))"
'Encadrement
For i = 7 To 12
With .Range("A14:U" & .Range("A14").End(xlDown).Row).Borders(i)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Next i
'Elimination des zéros
Set Mazone = .Range("A14:U" & .Range("A14").End(xlDown).Row)
For Each xCell In Mazone
If xCell = 0 Then xCell.ClearContents
Next xCell
'passage en valeurs
Mazone = Mazone.Value
.Shapes.Range(Array("Rounded Rectangle 1")).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "Calculs Terminés"
.Range("B12").Select
End With
MsgBox "Traitement terminé!"
Application.ScreenUpdating = False
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C1:C9")) Is Nothing Then
ActiveSheet.Shapes.Range(Array("Rounded Rectangle 1")).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "Calculer..."
End If
Target.Select
End Sub