Private Sub Worksheet_Change(ByVal Target As Range)
Dim LigSFam As Integer
Dim sousfam As String
Dim RefFamille As String
Dim Secteur As String
Dim Comptage As String
Dim MonDico As Object
Dim c As Range
Dim i As Integer 'Ligne colonne A
Dim j As Integer, l As Byte
Dim DerLigListe As Integer 'Dernière ligne de la colonne A
Dim xx As Integer 'les chiffre de la cellule A
Dim yy As Integer 'valeur de la cellule C
Dim aa As String '2 première lettre de la cellule A'On Error Resume Next
If Target.Column = 15 Then
If Target.Offset(0, -13).Value = "" Then
LigSFam = Target.Row
'''Recherche numéro référence
sousfam = Target.Value
RefFamille = Target.Offset(0, -1).Value
Secteur = Target.Offset(0, -2).Value
Select Case Secteur
Case "CLIMATISATION"
premsecteur = "F"
Case "SAV CHAUFFAGE", "SAV SANITAIRE"
premsecteur = "D"
Case "COUVERTURE"
premsecteur = "T"
Case "SOLAIRE"
premsecteur = "C"
Case Else
premsecteur = Left(Replace(Secteur, "O", "X"), 1)
End Select
Select Case RefFamille
Case "BALLON"
PremFamille = "BL"
Case "CHAUDIERE"
PremFamille = "CD"
Case "DIVERS"
PremFamille = "DV"
Case "FUMEE"
PremFamille = "FM"
Case Else
PremFamille = Left(Replace(RefFamille, "O", "X"), 2)
End Select
Select Case sousfam
Case "BALLON"
PremSFamille = "BL"
Case "VASE"
PremSFamille = "VS"
Case "ACCESSOIRE"
PremSFamille = "AS"
Case "COMPTEUR"
PremSFamille = "CP"
Case "EQUIPEMENT"
PremSFamille = "EP"
Case "PER"
PremSFamille = "PR"
Case "VARIA"
PremSFamille = "VR"
Case "COFFRET"
PremSFamille = "CF"
Case "VERTEO"
PremSFamille = "VT"
Case "RELAIS"
PremSFamille = "RS"
Case "THERMOCOUPLE"
PremSFamille = "TC"
Case "DIVERS"
PremSFamille = "DV"
Case "PROFIPRESS"
PremSFamille = "PF"
Case Else
PremSFamille = Left(Replace(sousfam, "O", "X"), 2)
End Select
rechref = premsecteur & PremFamille & PremSFamille
If Target.Offset(0, -7).Value = "VIESSMANN" Then
Target.Offset(0, -13).Value = "VI" & Target.Offset(0, -8).Value
Else
Set MonDico = CreateObject("Scripting.Dictionary")
With Worksheets("Articles")
For Each c In .Range("B2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row)
If Left(c.Value, 2) <> "VI" Then
If Not MonDico.exists(c.Value) Then MonDico.Add c.Value, c.Value
End If
Next c
Sheets("Ref utilisees").Range("A1").Resize(MonDico.Count, 1) = Application.Transpose(MonDico.keys)
End With
Set MonDico = Nothing
DerLigListe = Sheets("Ref utilisees").Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To DerLigListe
'aa = Left(Sheets("Ref utilisees").Range("A" & i), 2)
If Sheets("Ref utilisees").Range("A" & i).Value Like "VI*" Then
Else
Sheets("Ref utilisees").Range("B" & i) = Left(Sheets("Ref utilisees").Range("A" & i), 5)
End If
Next i
Sheets("Ref utilisees").Range("B:B").RemoveDuplicates Columns:=1, Header:=xlNo
Sheets("Ref utilisees").Range("B:B").Sort Key1:=Sheets("Ref utilisees").Range("B1"), Order1:=xlAscending, Header:=xlNo
For i = 1 To DerLigListe
l = Len(Sheets("Ref utilisees").Range("A" & i))
On Error Resume Next
j = WorksheetFunction.Match(Left(Sheets("Ref utilisees").Range("A" & i), 5), Sheets("Ref utilisees").Range("B:B"), 0)
xx = Right(Sheets("Ref utilisees").Range("A" & i), 3)
yy = Sheets("Ref utilisees").Range("C" & j)
If yy < xx Then Sheets("Ref utilisees").Range("C" & j) = xx
j = 0
Next i
On Error GoTo 0
'''Cherche les valeurs sur la feuille "Ref utilisees"
For Each NombreUtilise In ThisWorkbook.Sheets("Ref utilisees").Range("B1").CurrentRegion.Rows
If NombreUtilise.Cells(2) = rechref Then
ValeurNbrUtilisee = 0
ValeurNbrUtilisee = Sheets("Ref utilisees").Cells(NombreUtilise.Row, 3).Value
Exit For 'fin recherche
End If
Next NombreUtilise
If Application.CountIf(Sheets("Ref utilisees").Range("B:B"), rechref) = False Then
Comptage = Application.CountIfs(Sheets("Articles").Columns("B"), "*" & rechref & "*") + 1
Target.Offset(0, -13).Value = premsecteur & PremFamille & PremSFamille & Format(Comptage, "000")
Else
Target.Offset(0, -13).Value = premsecteur & PremFamille & PremSFamille & Format(ValeurNbrUtilisee + 1, "000")
End If
End If
Else
Exit Sub
End If
End If
End Sub