Option Explicit
Option Base 1
Public derLi As Integer
Public F1 As Worksheet, F2 As Worksheet
Public C As Range
Sub monSet()
Set F1 = Sheets("SAISIE FACTURES")
Set F2 = Sheets("ANALYSES FOURNISSEURS")
End Sub
Sub Combien()
Dim init As Byte '
Dim Fournisseurs As String
Dim NbFournisseurs As Byte
monSet
init = Application.CountA(F2.Columns(1).Value) - 1
Fournisseurs = "'" & F1.Name & "'!" & Range(Names("Fournisseurs").RefersTo).Address(-1, -1)
NbFournisseurs = Evaluate("=sumproduct(1/countif(" & Fournisseurs & "," & Fournisseurs & "))")
If init < NbFournisseurs Then MaJ
End Sub
Sub AjoutLigne()
Application.ScreenUpdating = False
With F1
derLi = .Columns(1).Find("*", , , , , xlPrevious).Row + 1
.Range("A" & derLi - 1 & ":Q" & derLi - 1).Copy .Range("A" & derLi & ":Q" & derLi)
For Each C In .Range("A" & derLi & ":Q" & derLi)
If Not C.HasFormula Then C.ClearContents
Next C
.Cells(derLi, 13) = "NP"
.Cells(derLi, 1).Activate
'SendKeys "{F2}", True
End With
Application.ScreenUpdating = True
End Sub
Sub MaJ()
Application.ScreenUpdating = False
monSet
Dim derLiF2 As Integer
Dim monDico As Scripting.Dictionary
Dim Fourn As Variant
Dim EnPlus As Integer
'recherche de la dernière ligne
derLi = F1.Columns(1).Find("*", , , , , xlPrevious).Row + 1
'insertion des noms de client dans le dictionnaire
Set monDico = CreateObject("Scripting.Dictionary")
For Each C In F1.Range("A6:A" & derLi)
If Not monDico.Exists(C.Value) Then monDico.Add C.Value, C.Value
Next
EnPlus = monDico.Count - 1
derLiF2 = F2.Columns(1).Find("*", , , , , xlPrevious).Row
'incrémentation des formules
F2.Range("A8:T" & derLiF2).Delete Shift:=xlUp
F2.Range("A7:T7").AutoFill Destination:=F2.Range("A7:T" & 6 + EnPlus)
'passage du dico à la feuille
F2.Range("A7:A" & 6 + EnPlus).Value = Application.Transpose(monDico.Items)
If Not Application.Sum(F1.Range("Retard").Value) = 0 Then ListeRetard
Application.ScreenUpdating = True
End Sub
Sub ListeRetard()
Application.ScreenUpdating = False
Dim i As Long, k As Long
Dim tabRetard() As Variant
Dim tabFactures() As Variant
Dim tabFournisseurs() As Variant
Dim tabListe() As Variant
Dim Couleur As Byte
monSet
tabRetard = F1.Range("Retard").Value
tabFactures = F1.Range("Factures").Value
tabFournisseurs = F1.Range("Fournisseurs").Value
k = 1
'liste des mauvais payeurs et des factures
For i = 1 To UBound(tabRetard, 1)
If tabRetard(i, 1) > 0 Then
ReDim Preserve tabListe(1 To 2, 1 To k)
tabListe(1, k) = tabFournisseurs(i, 1)
tabListe(2, k) = tabFactures(i, 1)
k = k + 1
End If
Next
'mise en forme
If k > 0 Then
With F2
.Range("W6").CurrentRegion.Clear 'Contents
.Range("W7:X" & 5 + k).Value = Application.Transpose(tabListe)
.Range("W6") = "Fournisseur": .Range("X6") = "Factures" & vbLf & "non réglées"
.Range("W6:X6").HorizontalAlignment = xlCenter
.Range("W6:X6").VerticalAlignment = xlVAlignCenter
.Range("W6:X6").Font.Bold = True
.Range("W7:X" & 5 + k).InsertIndent 1
.Range("W6:X" & 5 + k).Borders.Weight = xlThin
'applicatiuon d'une couleur aux impayés
For Each C In .Range("X7:X" & 5 + k)
Couleur = Application.Index(Range("Retard"), Application.Match(Cells(C.Row, 24), Range("Factures"), 0))
Select Case Couleur
Case 1: C.Interior.ColorIndex = 50 '14
Case 2: C.Interior.ColorIndex = 44
Case 3: C.Interior.ColorIndex = 3
End Select
Next C
End With
End If
Application.ScreenUpdating = True
End Sub
