XL 2010 Incrementer un tableau sous condition de couleur

SSIAP2

XLDnaute Occasionnel
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
Code:
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
 

Pièces jointes

  • colorteste.xlsm
    17.8 KB · Affichages: 58

sousou

XLDnaute Barbatruc
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...
 

Pièces jointes

  • Copie de colorteste.xlsm
    19.8 KB · Affichages: 42

vgendron

XLDnaute Barbatruc
Hello

essaie ce code
VB:
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

XLDnaute Occasionnel
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

XLDnaute Barbatruc
Hello
Avec ce code modifié
VB:
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
 

SSIAP2

XLDnaute Occasionnel
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
 

Pièces jointes

  • Copie de colorteste-2.xlsm
    19.9 KB · Affichages: 36

SSIAP2

XLDnaute Occasionnel
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
 

Pièces jointes

  • Copie de Copie de colorteste-2.xlsm
    31.7 KB · Affichages: 24

SSIAP2

XLDnaute Occasionnel
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
 

Pièces jointes

  • Copie de Copie de colorteste-2.xlsm
    31.7 KB · Affichages: 26

SSIAP2

XLDnaute Occasionnel
Code:
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

XLDnaute Barbatruc
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.
 

Pièces jointes

  • colorteste-3.xlsm
    36.7 KB · Affichages: 30

Discussions similaires

Membres actuellement en ligne

Statistiques des forums

Discussions
290 974
Messages
1 911 776
Membres
177 382
dernier inscrit
Cdrik4
Haut Bas