XL 2010 incrementer une liste en ligne sous condition une bdd

[creolia]

Bonjour à tous

je viens vous demander un peut d'aide pour un soucis que je n'arrive pas à résoudre

j'ai une liste de nom d'équipier dans la colonne D qui sont colorier en rouge

je souhaiterais que les cellules colorier en rouge incrémente ma feuille de garde en H et I

j'ai fait une petite macro qui fonctionne pas mal pour les autres fonction mais pour la fonction équipier cela ne fonctionne pas il me met que le dernier nom en rouge (voir la piece jointe)

pouvez vous m'aider svp merci

 

[Hieu]

Salut Creolia,

Avec ce que j'ai compris. Quelques modifs (perso, j'prefere la fonction "range" à la fonction "cells"

Sub crea_CCF_M_GRP()
Set l = Sheets("Liste")
k = 11
For j = 0 To 34 Step 34
    If j = 34 Then k = 20
    For i = 4 To 34
    If l.Range("a" & i).Offset(j, 0).Interior.ColorIndex = l.Range("M14").Interior.ColorIndex Then l.Range("f" & k) = l.Range("a" & i).Offset(j, 0)
    If l.Range("b" & i).Offset(j, 0).Interior.ColorIndex = l.Range("M14").Interior.ColorIndex Then l.Range("g" & k) = l.Range("b" & i).Offset(j, 0) '
    If l.Range("c" & i).Offset(j, 0).Interior.ColorIndex = l.Range("M14").Interior.ColorIndex Then l.Range("h" & k) = l.Range("c" & i).Offset(j, 0) '
    If l.Range("d" & i).Offset(j, 0).Interior.ColorIndex = l.Range("M14").Interior.ColorIndex Then l.Range("i" & k) = l.Range("d" & i).Offset(j, 0) '
    Next i
Next j
End Sub

 

[creolia]

Bonjour Hieu et merci pour ton aide mais je crois on c'est mal compris ou plutôt je me suis mal exprimé ce que tu me propose je sais deja le faire c'est juste que je souhaite que les agents EQ dans les noms source s'affiche en H et I voir la demo2 c'est cela qui me complique les choses

 

[creolia]

Re bonjour if vous avez besoin plus info ou une autre solution je suis preneur merci d'avance

 

[job75]

Bonsoir creolia, Hieu,

La macro modifiée :

Sub crea_CCF_M_GRP()
Dim couleur&, x&, xx&, i%, rest(), n%, col%, lig&
With Sheets("Liste")
  couleur = .[M14].Interior.Color
  x = 4
  xx = 11
  For i = 1 To 31
    ReDim rest(1 To 4) 'tableau, plus rapide
    n = 0 'RAZ
    For col = 2 To 4
      For lig = x To x + 30
        If .Cells(lig, col).Interior.Color = couleur Then
          n = n + 1
          If n < 5 Then rest(n) = .Cells(lig, col)
        End If
    Next lig, col
    .Cells(xx, 6).Resize(, 4) = rest 'décharge du tableau
    x = x + 34
    xx = xx + 9
  Next i
End With
End Sub

A+

 

[job75]

Re,

Si les tableaux colorés ne sont pas dans la feuille "Liste", enlever le point devant Cells(lig, col).

C'est alors la feuille active qui sera étudiée.

A+

 

[job75]

Re,

Un test supplémentaire pour que seule la 1ère cellule colorée soit prise en compte en colonnes B et C :

Sub crea_CCF_M_GRP()
Dim couleur&, x&, xx&, i%, rest(), n%, col%, lig&
With Sheets("Liste")
  couleur = .[M14].Interior.Color
  x = 4
  xx = 11
  For i = 1 To 31
    ReDim rest(1 To 4) 'tableau, plus rapide
    n = 0 'RAZ
    For col = 2 To 4
      For lig = x To x + 30
        If .Cells(lig, col).Interior.Color = couleur Then
          n = n + 1
          If n < 5 Then rest(n) = .Cells(lig, col)
          If col < 4 Then Exit For '1ère cellule colorée en colonnes B et C
        End If
    Next lig, col
    .Cells(xx, 6).Resize(, 4) = rest 'décharge du tableau
    x = x + 34
    xx = xx + 9
  Next i
End With
End Sub

 

[creolia]

bonjour job75 et merci pour ton aide j'ai put l'adapter et sa fonctionne parfaitement un grand merci à toi