copie cellule sous condition de couleur

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A:C]) Is Nothing Then Exit Sub
Dim plage As Range, ad1$, ad2$, formule$, cel As Range
Set plage = Range("D1:D" & Range("A65536").End(xlUp).Row)
[COLOR="Red"]ad1 = "Feuil1!C[-4]"[/COLOR]
ad2 = "Feuil1!" & plage.Address(ReferenceStyle:=xlR1C1)
formule = "=INDEX(" & ad1 & ",SMALL(IF(" & ad2 & "<10,ROW(" & ad2 & ")),ROWS(R2C:RC)))"
With Sheets("Feuil3")
  .Range("E2:G65536").ClearContents
  For Each cel In .Range("[COLOR="red"]E2:G[/COLOR]" & plage.Count)
    cel.FormulaArray = formule 'formule matricielle
    If IsError(cel) Then cel = "" Else cel = cel.Value
  Next
End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [COLOR="Red"][A:D][/COLOR]) Is Nothing Then Exit Sub
Dim plage As Range, ad1$, ad2$, formule$, cel As Range
Set plage = Range("D1:D" & Range("A65536").End(xlUp).Row)
ad1 = "Feuil1!C[-4]"
ad2 = "Feuil1!" & plage.Address(ReferenceStyle:=xlR1C1)
formule = "=INDEX(" & ad1 & ",SMALL(IF(" & ad2 & "<10,ROW(" & ad2 & ")),ROWS(R2C:RC)))"
With Sheets("Feuil3")
  .Range("E2:G65536").ClearContents
  For Each cel In .Range("E2:G" & plage.Count)
    cel.FormulaArray = formule 'formule matricielle
    If IsError(cel) Then cel = "" Else cel = cel.Value
  Next
End With
End Sub

http://www.cijoint.fr/cjlink.php?file=cj201001/cijQtwblXT.zip

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A:AY]) Is Nothing Then Exit Sub 'test définissant LA ZONE CONCERNEE
Dim derlig As Long, plage As Range, ad1$, ad2$, formule$, cel As Range, n As Range
Application.ScreenUpdating = False
[COLOR="Red"]derlig = Columns("A").Find("?*", LookIn:=xlValues, SearchDirection:=xlPrevious).Row 'dernière ligne en colonne A où la valeur est <> ""[/COLOR]
Set plage = [COLOR="red"]Range("AY1:AY" & derlig)[/COLOR] 'définit la plage ou la valeur designe l'alerte
ad1 = "DONNEE!C[-10]" 'adresse relative de la 1ère colonne où se trouvent les donnes source [-10] différence des n° des colonnes B (source) et L (destination)
ad2 = "DONNEE!" & plage.Address(ReferenceStyle:=xlR1C1)
formule = "=INDEX(" & ad1 & ",SMALL(IF(" & ad2 & "<10,ROW(" & ad2 & ")),ROWS(R2C:RC)))"
With Sheets("ACCUEIL") 'partis réserné a la feuille cible ou se trouvent le tableau des alarme copier
  .Range("L7:N65536").ClearContents 'ici ou doit etre copier la premiere cellule alarme
  For Each cel In [COLOR="red"].Range("L7:N" & derlig)[/COLOR] 'plage où l'on entre la formule
    cel.FormulaArray = formule 'formule matricielle
    If IsError(cel) Then cel = "" Else cel = cel.Value
  Next
End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A:AY]) Is Nothing Then Exit Sub 'test définissant LA ZONE CONCERNEE
Dim derlig As Long
Application.ScreenUpdating = False
Me.AutoFilterMode = False 'désactive le filtre automatique s'il est en place
derlig = Columns("A").Find("?*", LookIn:=xlValues, SearchDirection:=xlPrevious).Row 'dernière ligne en colonne A où la valeur est <> ""
[COLOR="Red"]Range("AY6:AY" & derlig)[/COLOR].AutoFilter Field:=1, Criteria1:="<10" 'filtre sur la colonne AY
Sheets("ACCUEIL").Range("L7:N65536").ClearContents 'vide toute la zone de restitution
Workbooks.Add 'nouveau document provisoire
Range("B6:D" & derlig).Copy ActiveSheet.Range("B6") 'copie la plage (filtrée) vers le document provisoire
ThisWorkbook.Sheets("ACCUEIL").Range("L7:N" & derlig) = ActiveSheet.Range("B7:D" & derlig).Value 'copie les valeurs sur la plage de restitution
ActiveWorkbook.Close False 'fermeture/suppression du document provisoire
Me.AutoFilterMode = False 'désactive le filtre automatique
End Sub

Option Base 1

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A:AY]) Is Nothing Then Exit Sub 'test définissant LA ZONE CONCERNEE
Dim derlig As Long, tablo, tablotest, tablofinal(), i As Long, n As Long
derlig = Columns("A").Find("?*", LookIn:=xlValues, SearchDirection:=xlPrevious).Row 'dernière ligne en colonne A où la valeur est <> ""
tablo = Range("B7:D" & derlig).Value2 'plage des données à copier - Value 2 à cause des dates
tablotest = Range("AY7:AY" & derlig) 'plage à tester
For i = 1 To UBound(tablotest)
  If tablotest(i, 1) < 10 Then
    n = n + 1 'compte les lignes copiées
    ReDim Preserve tablofinal(3, n) 'tableau de restitution évolutif (seule la 2ème dimension peut évoluer)
    tablofinal(1, n) = tablo(i, 1): tablofinal(2, n) = tablo(i, 2): tablofinal(3, n) = tablo(i, 3) 'remplissage du tableau de restitution
  End If
Next
With Sheets("ACCUEIL")
  .Range("L7:N65536").ClearContents 'vide la plage de restitution
  .Range("L7").Resize(n, 3) = Application.Transpose(tablofinal) 'copie le tableau de restitution
End With
End Sub