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+
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...
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+
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é
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 !!
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.