Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B:C]) Is Nothing Then Exit Sub
Dim critere$, tablo, resu(), i&, n&
Application.EnableEvents = False 'désactive les évènements
If [B2] = "" Then [C2] = "": GoTo 1
If Not Intersect(Target, [B2]) Is Nothing Then [C2] = ""
critere = LCase(Left([B2], 1) & Chr(1) & "*" & CStr([C2])) & "*"
tablo = Sheets("Données Techniques").[A2].CurrentRegion.Resize(, 3) 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To 3)
For i = 2 To UBound(tablo)
If LCase(tablo(i, 3) & Chr(1) & tablo(i, 1)) Like critere Then
n = n + 1
resu(n, 1) = tablo(i, 3)
resu(n, 2) = tablo(i, 1)
End If
Next
'---restitution---
1 If FilterMode Then ShowAllData 'si la feuille est filtrée
With [B5] '1ère cellule de restitution
If n Then .Resize(n, 3) = resu
.Offset(n).Resize(Rows.Count - n - .Row + 1, 3).ClearContents 'RAZ en dessous
End With
Columns(3).AutoFit 'ajustement largeur
With UsedRange: End With 'actualise la barre de défilement verticale
Application.EnableEvents = True 'réactive les évènements
End Sub
Sub Transfert()
Dim n&, w As Worksheet
With [A4].CurrentRegion.Resize(, 4)
n = Application.CountIf(.Columns(4), ">0")
If [B2] = "" Or n = 0 Then Exit Sub
If MsgBox("Transférer " & n & " ligne" & IIf(n = 1, " ?", "s ?"), 36, "Transfert") = 7 Then Exit Sub
Application.ScreenUpdating = False
Set w = Sheets(CStr([B2])) 'feuille du fournisseur
.AutoFilter 4, ">0" 'filtre automatique
Intersect(Range("C5:D" & Rows.Count), .Cells).Copy w.Cells(w.Rows.Count, 1).End(xlUp)(2) 'copier-coller
.AutoFilter 'désactive le filtre
End With
w.Columns(1).AutoFit 'ajustement largeur
w.Activate
[B2] = "" 'RAZ
End Sub
Sub RAZ()
'---pour les feuilles des fournisseurs---
With ActiveSheet
If .[A3] = "Plante" Then .Range("A4:B" & .Rows.Count).Delete xlUp
End With
End Sub