Option Explicit
Private Sub Worksheet_Activate()
Worksheet_Change [C2] 'lance la macro
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B:E]) Is Nothing Then Exit Sub
Dim vide As Boolean, fournisseur$, critere$, tablo, resu(), i&, n&
vide = [B2] & [C2] = ""
fournisseur = [B2]
critere = LCase(fournisseur & Chr(1) & CStr([C2])) & "*" 'textes commenant par C2.....
tablo = Sheets("BDD_Technique").[A2].CurrentRegion.Resize(, 6) 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To 7)
For i = 2 To UBound(tablo)
If Not vide And LCase(IIf(fournisseur = "", "", tablo(i, 4)) & Chr(1) & tablo(i, 1)) Like critere Then
n = n + 1
resu(n, 1) = tablo(i, 4)
resu(n, 2) = tablo(i, 1)
resu(n, 3) = tablo(i, 2)
resu(n, 4) = tablo(i, 5)
resu(n, 5) = tablo(i, 6)
End If
Next
'---restitution---
Application.EnableEvents = False 'd_sactive les _vnementssss
If FilterMode Then ShowAllData 'si la feuille est filtr_e
With [B5] '1re cellule de restitutionnnn
If n Then
.Resize(n, 7) = resu
.Resize(n, 7).Borders.Weight = xlThin 'bordures
End If
.Offset(n).Resize(Rows.Count - n - .Row + 1, 7).ClearContents 'RAZ en dessous
.Offset(n).Resize(Rows.Count - n - .Row + 1, 7).Borders.LineStyle = xlNone
End With
Columns(3).AutoFit 'ajustement largeur
ActiveWindow.ScrollRow = 1 'cadrage
With UsedRange: End With 'actualise la barre de d_filement verticale
Application.EnableEvents = True 'r_active les _vnementssss
End Sub
Sub Transfert()
Dim n&, tablo, w As Worksheet, nf$, i&
With [A4].CurrentRegion
n = Application.CountIf(.Columns(7), ">0")
If n = 0 Then Exit Sub
If MsgBox("Transf_rer " & n & " ligne" & IIf(n = 1, " ?", "s ?"), 36, "Transfert") = 7 Then Exit Sub
tablo = .Resize(, 8) 'matrice, plus rapide
For Each w In Worksheets
nf = LCase(w.Name)
If nf Like "devis*" Then
For i = 2 To UBound(tablo)
If nf Like "*" & LCase(tablo(i, 2)) And Val(tablo(i, 7)) > 0 Then _
.Cells(i, 3).Resize(, 6).Copy w.Cells(w.Rows.Count, 2).End(xlUp)(2) 'copier-coller
Next i
w.Columns(2).AutoFit 'ajustement largeur
w.Columns(7).AutoFit 'ajustement largeur
End If
Next w
End With
End Sub
Sub RAZ()
'---pour les feuilles des devis---
With ActiveSheet
If .Name Like "Devis*" Then .Rows("2:" & .Rows.Count).Delete xlUp
End With
End Sub