XL 2010 Incrementer un tableau sous condition de couleur

[SSIAP2]

Bonjour à tout le monde

voila donc dans la colonne F j'ai une liste séparer en 4 zones dans chaque zone une liste de noms dont les agent sélectionner est colorer en jaune je voudrais alimenter un tableau en colonne B par les 3 noms selectionner en fond jaune suivant sa zone qui lui est attribuer.

en D j'ai mis le résultat souhaitait

j'utilise une macro déja qui fonctionne bien mais ne me met un nom par zone et nom les 3 selectionner

Sub crea_EQ1_M()
With Sheets("Feuil1").Select
x = 4
xx = 4
For i = 1 To 4
For a = 0 To 11
v = x + a
If Cells(v, 6).Interior.ColorIndex = 6 Then Sheets("Feuil1").Cells(xx, 2) = Sheets("Feuil1").Cells(v, 6) 'Else Sheets("Garde").Cells(xx, 1) = ""
Next a
x = x + 34
xx = xx + 8
Next i
End With
End Sub

pouvez vous me donner un coup de main svp

 

[sousou]

bonjour
Bien que la construction de ta feuille soit pas la plus optimisée ( si plus de zone.... si plus d'agents....)
Tu trouveras dans le fichier joint une méthode comme une autre...

 

[vgendron]

Hello

essaie ce code

Sub dispatch()

NomZone = Range("F1")
i = 1
j = 7
For Each ele In Range("F1:F48")
    If ele Like "*Zone*" Then
        NomZone = Left(ele, 6)
        Set c = ActiveSheet.Range("A:A").Find(NomZone, lookat:=xlWhole)
        If Not c Is Nothing Then j = c.Row + 5
    ElseIf ele Like "*Toto*" Then
        If ele.Interior.ColorIndex = 6 Then
            Range("B" & j) = ele
            j = j + 1
        End If
    End If
Next ele
End Sub

 

[SSIAP2]

bonjour sousou bonjour vgendron j'ai essayer vos 2 code
sousou: malheureusement quand j utilise ta macro il me remplis sur la ligne CDP CA un peu EQP alors ce que je souhaite sais qui soit copier en face CQP1 CQP2 CQP3

vgendron : le code de vgendron est parfait sauf un petit truc si je colorie plus de 3 cellule suite à une erreur ou autre les autre ligne en B s’incrémente peut t on limité la copie de la cellule qu'a 3 valeur meme si il y en a 4 qui est coloré exemple les 3 premier merci d'avance mais c'est déja un super beau boulot

 

[vgendron]

Hello
Avec ce code modifié

Sub dispatch()

NomZone = Range("F1")
i = 1
j = 7
For Each ele In Range("F1:F48")
    If ele Like "*Zone*" Then
        NomZone = Left(ele, 6)
        NbColorés = 1
        Set c = Range("A:A").Find(NomZone, lookat:=xlWhole)
        If Not c Is Nothing Then j = c.Row + 5
    ElseIf ele Like "*Toto*" Then
        If ele.Interior.ColorIndex = 6 Then
            If NbColorés < 4 Then
                Range("B" & j) = ele
                NbColorés = NbColorés + 1
                j = j + 1
            Else: MsgBox ("trop de joueurs colorés dans la zone " & NomZone)
            End If
        End If
    End If
Next ele
End Sub

 

[sousou]

Ok
Mais pour moi si tu lance test, ç’a me rempli EQP1........
Mais j'ai peu-être rien compris!.?

 

[SSIAP2]

re bonjour sousou j'ai tester sur mon programme ta méthode effectivement sa fonctionne mieux une question en revanche si à la place des zone je met une date 01/01/2016 ou je doit modifies le code pour qu'il soit reconnu comme pour la zone svp merci

 

[sousou]

tu remplaces la recherche de 6premier caractères par la date comme ci dessous.
Set debtable = ActiveSheet.Columns(1).Find(z) 'recherche dans la colonne 1 le début du tableau de la zone concernée

 

[SSIAP2]

re sousou parfaitun grand merci à vous deux

 

[SSIAP2]

tu remplaces la recherche de 6premier caractères par la date comme ci dessous.
Set debtable = ActiveSheet.Columns(1).Find(z) 'recherche dans la colonne 1 le début du tableau de la zone concernée

rebonjour sousou je sais je suis un peu beaucoup embêtant toujour dans l cadre de ta macro j'ai essayer mettre les garde sur une feuille et la BDD dans filtre et mofifier la macro pour pas t'embeter j'ai essayer plusieur solution durant la journée mais je suis impuissant donc comment pourais je faire pour réaliser cete migration merci d'avance

 

[SSIAP2]

rebonjour sousou je sais je suis un peu beaucoup embêtant toujour dans l cadre de ta macro j'ai essayer mettre les garde sur une feuille et la BDD dans filtre et mofifier la macro pour pas t'embeter j'ai essayer plusieur solution durant la journée mais je suis impuissant donc comment pourais je faire pour réaliser cete migration merci d'avance

 

[SSIAP2]

Sub test()
Sheets("Feuil2").Select
zones = Array(1, 14, 27, 39) 'définition des lignes pour les 4 zones

For N = 0 To UBound(zones)
 
  Call suite(Sheets("Feuil2").Cells(zones(N), 7)) 'pour chaque zone bdd

Next
Sheets("Feuil1").Select
End Sub

Sub suite(z)

N = 0
c = 1

Set debtable = Sheets("Feuil1").Columns(1).Find(z) 'recherche dans la colonne 1 le début du tableau de la zone concernée
While z.Offset(N, 0) <> ""                  'Tant que la cellule est différente de ""
    z.Select
    If z.Offset(N, 0).Interior.ColorIndex = 6 Then          ' si sa couleur est jaune
        debtable.Offset(3 + c, 4) = z.Offset(N, 0)          ' inscription du résultat
    c = c + 1  'compteur de résultat par zone
    End If
    N = N + 1

Wend

End Sub

RE je crois j'ai trouver dans la feuil ou se trouve la base de donnee je met ta macro comme ceci

 

[sousou]

Bonsoir
Je pense que nous ne sommes pas sur la bonne piste si tu veux changé les choses!
J'ai donc repris l'ensemble du problème mais avec une solution plus propre et plus évolutive
J'ai ajouter un effacement des données pratiques pour tes tests
J'ai profité pour ajouter les matin et les après_midi
Tout se trouve dans un module! (c'est plus sain)
Tu pourras supprimer tous dans les feuille

Ne t'étonne pas de n'avoir plus de réponse à partir de lundi je m'absente et internet n'est guère accessible.