Extraction données puis remise en forme

Bonjour,

Je souhaite extraire les données de la feuille "Global" vers les onglets semaine "S15" (pour semaine 15), "S16" etc.

Le but est que les individus remplissent la feuille "Global" et que ces données soient retranscrites automatiquement dans les feuilles suivantes.

Pour cela les feuilles suivantes détaillent chaque semaine.

Ainsi la feuille "S15" détaille la semaine 15 (référence cellule AC15 feuille "Global").

Cette feuille "S15" reprend la colonne AC15 feuille "Global" et la détaille. Ainsi toutes les individus ayant mis un "M" dans leurs cases se voient apparaitre dans le tableau "Marseille" de feuille "S15". Leurs noms sont écrits en face de la qualification cochée dans "Global" colonne "F4" à "AA4".

Dès qu'un nom apparait deux fois il est surligné en rouge.

Le schéma est répété dans les feuilles semaine pour l'ensemble des codes :

D = Danemark M = Marseille

R = Rouen P = Paris

L = Lyon A = autres

i = indisponible

La feuille "S15" prend comme référence la case AC4 de la feuille "Global". Réf indiquée en B1 de la feuille "S15".

Ainsi il est possible de créer une feuille par semaine en modifiant juste la référence.

J'ai essayé d'appliquer des conditions avec la fonction SI et RECHERCHE mais je me retrouve bloqué et n'arrive pas à remplir les feuilles semaines correctement.

Auriez-vous une idée sur une manière de procéder s'il vous plait ?

Cordialement.

Salut Mennen,

voici ton fichier auquel il manque encore la couleur pour les travailleurs qui apparaissent 2X et plus dans un même tableau.

Les couleurs et l'optimisation du code, ce sera pour demain! 8)

Pour démarrer la macro, un petit bouton rouge...

Je te laisse vérifier l'exactitude de mes calculs!

Private Sub cmdGO_Click()
'
Dim wks As Worksheet
Dim tTab
'
iCol = Cells(4, Columns.Count).End(xlToLeft).Column
iRow = Range("C" & Rows.Count).End(xlUp).Row
'
Application.ScreenUpdating = False
'
For x = 29 To iCol
    sWKS = "S" & CStr(Cells(4, x))
    iFlag = 0
    For Each wks In Worksheets
        If wks.Name = sWKS Then
            iFlag = 1
            Exit For
        End If
    Next
    If iFlag = 0 Then
        If Sheets.Count = 1 Then
            Sheets.Add after:=Worksheets("Global")
        Else
            sWKS1 = "S" & CStr(Cells(4, x - 1))
            Sheets.Add after:=Worksheets(sWKS1)
        End If
        ActiveSheet.Name = sWKS
    End If
    Set wks = Worksheets(sWKS)
    wks.Rows.RowHeight = 15
    wks.Columns.ColumnWidth = 11
    wks.[A1] = "Référence"
    wks.[B1] = Cells(4, x)
    For y = 1 To 7
        Range("AAA1000:AAJ1023").Copy Destination:=wks.Range("A" & -24 + (y * 27) & ":J" & -1 + (y * 27))
        wks.Range("A" & -24 + (y * 27) + 10).Value = sWKS
        wks.Range("F" & -24 + (y * 27)).Value = Choose(y, "Autres", "Danemark", "Lyon", "Marseille", "Paris", "Rouen", "Indisponible")
    Next
    '
    For y = 5 To iRow
        sNom = Cells(y, 3)
        sVille = UCase(Cells(y, x))
        If sVille <> "" And sVille <> " " Then
            iFlag = 0
            iFlag = Switch(sVille = "A", 1, sVille = "D", 2, sVille = "L", 3, sVille = "M", 4, sVille = "P", 5, sVille = "R", 6, sVille = "I", 7)
            If iFlag > 0 Then
                For Z = 6 To 27
                    If Cells(y, Z) = UCase("x") Then
                        iTemp1 = Switch(Z = 6, 2, Z = 7, 3, Z = 8, 4, Z = 9, 5, Z = 11, 7, Z = 12, 8, Z = 13, 9, Z = 15, 11, Z = 16, 12, Z = 17, 13, Z = 18, 14, Z = 19, 15, Z = 20, 16, Z = 21, 17, Z = 23, 19, Z = 24, 20, Z = 25, 21, Z = 26, 22, Z = 27, 23)
                        iTemp = -24 + (iFlag * 27) + iTemp1
                        iCol1 = wks.Cells(iTemp, Columns.Count).End(xlToLeft).Column + 1
                        wks.Cells(iTemp, iCol1) = sNom
                    End If
                Next
            End If
        End If
    Next
Next
'
Worksheets("Global").Select
Application.ScreenUpdating = True
'
End Sub

A+

Bonjour Mennen,

la version avec les couleurs et quelques améliorations invisibles.

    For y = 5 To iRow
        sNom = Cells(y, 3)
        sVille = UCase(Cells(y, x))
        If sVille <> "" And Left$(sVille, 1) <> " " Then
            iFlag = 0
            iFlag = Switch(sVille = "A", 1, sVille = "D", 2, sVille = "L", 3, sVille = "M", 4, sVille = "P", 5, sVille = "R", 6, sVille = "I", 7)
            If iFlag > 0 Then
                Erase tTab
                iNb = 0
                For Z = 6 To 27
                    If Cells(y, Z) = UCase("x") Then
                        iNb = iNb + 1
                        iTemp1 = Switch(Z = 6, 2, Z = 7, 3, Z = 8, 4, Z = 9, 5, Z = 11, 7, Z = 12, 8, Z = 13, 9, Z = 15, 11, Z = 16, 12, Z = 17, 13, Z = 18, 14, Z = 19, 15, Z = 20, 16, Z = 21, 17, Z = 23, 19, Z = 24, 20, Z = 25, 21, Z = 26, 22, Z = 27, 23)
                        iTemp = -24 + (iFlag * 27) + iTemp1
                        iCol1 = wks.Cells(iTemp, Columns.Count).End(xlToLeft).Column + 1
                        tTab(iNb - 1, 0) = iTemp
                        tTab(iNb - 1, 1) = iCol1
                        wks.Cells(iTemp, iCol1) = sNom
                    End If
                Next
                If iNb > 1 Then
                    For Z = 0 To iNb - 1
                        wks.Cells(tTab(Z, 0), tTab(Z, 1)).Interior.Color = RGB(255, 0, 0)
                    Next
                End If
            End If
        End If
    Next

Cela dit, il faudra probablement imaginer quelque chose de mieux pour les couleurs : différencier les couleurs par individu, non?

Combien d'individus max peut-il y voir dans un tableau?

J'imagine déjà une suite pour faciliter la navigation dans ces feuilles mais, pour cela, il me faut explorer des zones inconnues de VBA! A suivre, peut-être...

A+

Alors là sincèrement .................

C'est énorme ce que tu as fais !

Si tu le veux bien (mais je ne veux pas te déranger plus !), voici des petites améliorations supplémentaires possibles :

• limiter les feuilles semaines jusqu'à S52 (la feuille Global tire jusqu'à S154 mais c'est inutile dans les faits)
• dans les feuilles semaines : les réf en A1 B1 sont inutiles puisques reprises sur les flancs des tableaux
• dans les feuilles semaines : au premier clic sur bouton rouge => créer en plus un tableau vide avec le canevas des A / D / L etc.

- dans les feuilles semaines : ce n'est pas obligatoire de différencier les couleurs pour les individus qui se répètent, sachant qu'il peut il y en avoir jusqu'à 20 par tableau cela nécessiterait une sacré palette peut-être ?

Ci-joint le canevas avec les tableaux vides en exemple dans S15 (ne pas reprendre cette version, je l'ai bidouillée et il y a des erreurs )

Cordialement.

Salut Mennen,

• feuilles jusque 52 : fait! Plus logique d'ailleurs! Il faudra quand même penser au cas où une année compte 53 semaines...
• références en [A1] - [B1] éliminées : fait!
• canevas en double : fait!
• palette de couleurs (54 couleurs de la palette ColorIndex) : fait!

Je t'envoie ça en l'état mais j'ai constaté une source d'erreur (d'affichage) si le nombre d'individus dépasse le nombre de colonnes prévues.

Je vais régler cela en soirée en calculant l'ajout de colonnes entre les canevas bloqués et manuels ce qui implique certains recalculs.

A+

Bonjour Mennen,

une nouvelle évolution de ton fichier auquel il ne manque plus que la touche finale : une macro écrite par macro dans chaque nouvelle feuille pour faciliter la navigation entre tableaux... pas réussi!

Le ruban est en place mais inerte! Prochaine étape!

Les couleurs sont maintenant associées à une couleur de fonte plus adaptée et les tableaux s'élargissent si, d'aventure, le nombre d'individus dépassait les limites standard.

J'ai, pour cela, utilisé les premières cellules de la ligne 4 pour y dissimuler diverses données indispensables à la gestion de l'affichage des tableaux. Prière de ne pas effacer!

A tester!

8)

A+

Excellent !

Inutile de t'embêter avec le ruban de navigation, c'est déjà tellement pratique ainsi !

Je n'ai pas rencontré de problème pour le moment et tout semble fonctionner parfaitement.

Donc encore un grand merci pour tout ce travail !

Salut Mennen,

grâce à l'intervention de Galopin01, j'ai pu réaliser ce qui manquait : la navigation dans tes feuilles S...

Une simple macro dans le module ThisWorkbook! GEANT comme possibilités de programmation!

Un vrai bonheur de découverte!

Enjoy!

A+

Très pratique ... !!

Et ce n'est pas fini!

Je peaufine et je t'envoie l'ultime version!

A+

Salut curulis57,

Il y aurait un autre fichier du même type à réaliser. Le premier que tu as fais travaille en semaine. Ce second détaillerai les jours pour chaque mois. Ceci avec d'autres caractéristiques à prendre en compte (comptabilité de permanence etc.).

Je ne veux pas t'embêter plus, tu m'as déjà bien aidé Mais si jamais cela t'intéresse je peux te faire suivre le "cahier des charges"

Bonne soirée.

Du coup serais-tu intéressé curulis57 ?

Cordialement.

Salut Mennen,

oui, certainement mais comme il s'agit d'un autre projet, ce serait très bien d'en faire un autre sujet que tout le monde puisse s'amuser!

Je bute encore sur une bête instruction pour terminer le projet précédant.

Dès que j'ai vaincu cette idiotie, je jetterai un oeil à ta prochaine demande!

A+

Inutile de t'embêter plus avec ce projet actuel, il fonctionne du feu de dieu !! Encore !

Comme convenu j'ai créer un nouveau post pour une nouvelle demande : https://forum.excel-pratique.com/excel/extraction-de-donnees-puis-remise-en-forme-le-retour-t88668.html

Si jamais tu es intéressé par le défi

Cordialement.