Copier une ligne entière dans un onglet en fonction de mot clé
Bonjour,
Dans mon message précédent, je pensais que la macro répondait à la totalité de mes problèmes. Or je m'aperçois qu'elle ne sélectionne pas les lignes où dans la colonne K il y a deux noms. Or le tableau final que l'on retrouve dans l'onglet filtre des noms devrait comporter quand je sélectionne Mr X mais aussi les lignes où il est en commun avec Mr B. De plus la macro actuelle quand je la lance sur mon fichier original qui comprend une quarantaine d'onglet de recherche, elle est très longue, je me dis alors qu'il serait plus judicieux de rechercher que les lignes de Mr X (soit la colonne K y compris quand il est en commun avec Mr B) ou il reste encore des actions à réaliser soit une case rouge dans le tableau qui va de la colonne M à X.
Est il possible au final que dans filtre des noms, ce tableau apparaisse avec des bordures comme dans l'exemple du fichier en sachant que chaque responsable a un tableau avec un nombre de ligne différente.
Merci pour votre aide
Salut cpin,
impatiente, va!
Je ne m'explique toujours pas la cause de la lenteur excessive...
Private Sub Worksheet_Change(ByVal Target As Range)
'
Dim tData
Dim sData As String, sNom As String, sSheet As String
'
Application.EnableEvents = False
Application.ScreenUpdating = False
'
If Not Intersect(Target, Range("D6")) Is Nothing Then 'si changement en [D6]
sNom = Target 'sData = nom
iRow = Range("D" & Rows.Count).End(xlUp).Row 'fond de la colonne [C] pour nettoyage...
If iRow > 24 Then '... si c'est déjà rempli
Range("A25:F" & iRow).ClearContents
Range("G25:R" & iRow).Interior.Color = xlNone
Range("A25:R" & iRow).Borders.LineStyle = xlNone
End If
iRow = 24
'préparation pour nouvel affichage
For x = 1 To 3
sSheet = Choose(x, "P1", "P2", "P3") 'choix des feuilles à scanner...
With Worksheets(sSheet)
For y = 4 To .Range("K" & Rows.Count).End(xlUp).Row '... jusqu'au fond de la colonne [K]
If Right(.Cells(y, 11), 1) <> Chr(10) Then sData = .Cells(y, 11) & Chr(10)
tData = Split(sData, Chr(10))
If InStr(sData, sNom) > 0 Then 'si cellule contient sNom
For k = 13 To 24
If .Cells(y, k).Interior.Color = RGB(255, 0, 0) Then
iRow = iRow + 1 'ligne d'affichage
Cells(iRow, 3) = sSheet & " - " & y 'nom feuille + ligne
Cells(iRow, 4) = sNom 'nom
For Z = 5 To 6
If .Range(IIf(Z = 5, "D", "J") & y).MergeCells Then
Cells(iRow, Z) = .Range(IIf(Z = 5, "D", "J") & y).MergeArea.Cells(1, 1)
Else
Cells(iRow, Z) = .Range(IIf(Z = 5, "D", "J") & y).Value 'risque
End If
Next
For Z = 1 To 12 'couleurs
Cells(iRow, 6 + Z).Interior.Color = .Cells(y, 12 + Z).Interior.Color
Next
If UBound(tData) > 1 Then
For Z = 0 To UBound(tData) - 1
If tData(Z) <> sNom Then
iRow = iRow + 1
Cells(iRow, 4) = tData(Z)
End If
Next
End If
Exit For
End If
Next
End If
Next
End With
Next
iRow = Range("D" & Rows.Count).End(xlUp).Row
If iRow > 24 Then Range("A25:R" & iRow).Borders.LineStyle = xlContinuous
End If
'
Application.ScreenUpdating = True
Application.EnableEvents = True
'
End SubA+
Bonjour,
C'est tout simplement le grand nombre d'appels de la fonction "Somcouleur()" qui prend du temps car comme demandée Volatile, les calculs sont prioritaires sur l'exécution de la procédure événementielle "Worksheet_Change()" donc, avant même d'effectuer la recherche, toutes les cellules appelant cette fonction sont calculées ensuite, il faudrait optimiser la recherche peut être avec Find() ou un filtrage car le code de ces fonctions et méthodes est compilé donc bien plus rapide.
Pour s'en rendre compte, il suffit de mettre en commentaire la fonction puis modifier la valeur pour exécuter la recherche.
Bonjour Theze,
merci pour l'explication.
Effectivement, sans cette f... fonction, les résultats sont instantanés.
Il faudrait que cpin nous explique le pourquoi du comment de ces calculs couleurs pour trouver un procédé plus efficace.
A+
Hello Curulis57,
Oui, car il se pourrai qu'un simple appel de la fonction sur l'activation de la feuille soit suffisant ce qui éviterai ce ralentissement permanent !
Bonsoir,
Je vous remercie énormément pour votre travail qui vous ne pouvez pas imaginer comment vous me faciliter le mien!!!! Moi je débute en vba et j'essaie en prenant à droite et à gauche de comprendre et de mettre en oeuvre de simple fonction.
En fait cette fonction me permet de calculer instantanément l'état de mon tableau de bord : je m'explique. En fait j'ai un ensemble de processus avec un ensemble d'actions intégré à ce processus et j'ai besoin de savoir combien d'actions ont été réalisées au 1er trimestre ensuite au 2nd puis au 3ème et en fin d'année sur le nombre d'actions prévues sur le 1er trimestre, 2nd, 3ème et enfin année. Comme je débute j'ai cherché un peu partout et je suis arrivée à ce travail là je reconnais qu'à priori ce n'est pas le sommet mais quand vous connaissez très peu vous trouvez cela formidable. Peut être que vous pouvez l'améliorer mais moi pour l'instant je n'en ai pas les capacités au vue de mes connaissances en vba. J'espère que j'ai été claire dans mon explication
Je vous laisse le soin de le modifier si vous pensez que cela peut améliorer la seconde programmation . Merci pour votre énorme implication. Avez vous besoin d'un nouveau fichier ?
Je reconnais que je suis impatiente .....
Bonsoir
En copiant collant ce programme qui pour moi est exceptionnel... J'aimerai tout de même le comprendre : est il possible d'avoir une explication en plus des explications déjà existante. Sans trop abuser merci
Salut cpin,
explications supplémentaires du code...
Tu as bien demandé que ne soient affichées que les actions non-réalisées!?
Private Sub Worksheet_Change(ByVal Target As Range)
'
Dim tData
Dim sData As String, sNom As String, sSheet As String
'
Application.EnableEvents = False
Application.ScreenUpdating = False
'
If Not Intersect(Target, Range("D6")) Is Nothing Then 'si changement en [D6]
sNom = Target 'sNom = nom
iRow = Range("D" & Rows.Count).End(xlUp).Row 'fond de la colonne [C] pour nettoyage...
If iRow > 24 Then '... si c'est déjà rempli, on efface tout...
Range("A25:F" & iRow).ClearContents '...texte, couleurs et bordures
Range("G25:R" & iRow).Interior.Color = xlNone
Range("A25:R" & iRow).Borders.LineStyle = xlNone
End If
iRow = 24 'préparation pour nouvel affichage
For x = 1 To 3
sSheet = Choose(x, "P1", "P2", "P3") 'choix des feuilles à scanner...
With Worksheets(sSheet)
For y = 4 To .Range("K" & Rows.Count).End(xlUp).Row '... de la ligne 4 jusqu'au fond de la colonne [K]
If Right(.Cells(y, 11), 1) <> Chr(10) Then sData = .Cells(y, 11) & Chr(10) 'j'ajoute un saut de ligne...
tData = Split(sData, Chr(10)) '...et je splitte le nom sur base de ce saut de ligne
If InStr(sData, sNom) > 0 Then 'si cellule contient sNom
For k = 13 To 24
If .Cells(y, k).Interior.Color = RGB(255, 0, 0) Then 'si il y a une action en rouge en 2018...
iRow = iRow + 1 'ligne d'affichage
Cells(iRow, 3) = sSheet & " - " & y 'nom feuille + ligne
Cells(iRow, 4) = sNom 'nom
For Z = 5 To 6 'si cellule en [D] ou [J] fusionnées, recherche de la valeur
If .Range(IIf(Z = 5, "D", "J") & y).MergeCells Then
Cells(iRow, Z) = .Range(IIf(Z = 5, "D", "J") & y).MergeArea.Cells(1, 1)
Else
Cells(iRow, Z) = .Range(IIf(Z = 5, "D", "J") & y).Value 'risque
End If
Next
For Z = 1 To 12 'couleurs
Cells(iRow, 6 + Z).Interior.Color = .Cells(y, 12 + Z).Interior.Color
Next
If UBound(tData) > 1 Then 'si le SPLIT révèle plusieurs valeurs = plusieurs noms
For Z = 0 To UBound(tData) - 1
If tData(Z) <> sNom Then 'copie des autres noms
iRow = iRow + 1
Cells(iRow, 4) = tData(Z)
End If
Next
End If
Exit For
End If
Next
End If
Next
End With
Next
iRow = Range("D" & Rows.Count).End(xlUp).Row 'valeur de fond de colonne [D]...
If iRow > 24 Then Range("A25:R" & iRow).Borders.LineStyle = xlContinuous '...pour dessiner bordures
End If
'
Application.ScreenUpdating = True
Application.EnableEvents = True
'
End SubPetite question : en 2020, qu'as-tu prévu pour ton tableau?
A+
Bonjour
Je te remercie pour tes explications mais je n'en suis pas encore à ce stade de vba. Pour 2020, il faut voir......
Sans trop insister, pensez vous que l'on peut modifier le premier programme somcouleur pour que le deuxième programme s’exécute plus rapidement : faut il enlever application.volatile ou comment puis je faire différemment ?
Si vous pouviez m'aiguiller pour que je puisse le faire seule, j'avoue que l'explication de theze est au dessus de mes compétences mais je peux essayer : faut il que j'utilise find pour compter le nombre de cellules rouges ? et faire des calculs sur toutes les lignes de façon automatiques ?
merci pour ton aide
Salut cpin,
voilà ma version afin de fuidifier ta recherche.
Toutes les formules sont effacées, la fonction de calcul-couleur bannie.
Tu trouveras la procédure suivante dans le module 'ThisWorkbook', valable donc pour toutes les feuilles 'P1,"P.."
Il te suffit de cliquer sur les cellules couleur (1er clic = vert, 2e rouge, 3e blanc), chacune étant notée 1,2 ou 3 selon sa couleur, les calculs étant exécutés immédiatement.
Le filtrage des noms n'étant plus pollué par la fonction-couleurs, les résultats s'affichent très vite.
Tout ceci ne fonctionnera qu'avec ce fichier, ayant dû valider chaque cellule-couleur pour le nouveau système.
J'ai cru lire un jour que tu devais filtrer 40 feuilles?! Juste?
Il faudrait dans ce cas revoir la macro de filtrage... A toi de me dire...
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
'
Application.ScreenUpdating = False
'
If Left(Sh.Name, 1) = "P" Then
iRow = Range("K" & Rows.Count).End(xlUp).Row
If Not Intersect(Target, Range("M4:AJ" & iRow)) Is Nothing And Range("K" & Target.Row) <> "" Then
iTRow = Target.Row
iTCol = Target.Column
'Couleurs
Target = IIf(Target = 1, 2, IIf(Target = 2, 3, 1))
Target.Interior.Color = Choose(Target, RGB(0, 180, 80), RGB(255, 0, 0), xlNone)
Target.Font.Color = Choose(Target, RGB(0, 180, 80), RGB(255, 0, 0), xlNone)
'Calcul de pourcentage
iCol = IIf(iTCol Mod 3 = 0, iTCol, iTCol + (3 - iTCol Mod 3))
sCol1 = Split(Columns(iCol - 2).Address(ColumnAbsolute:=False), ":")(1)
sCol2 = Split(Columns(IIf(iCol < 25, 38, 52) + Cells(3, iCol)).Address(ColumnAbsolute:=False), ":")(1)
Range(sCol2 & iTRow).Value = WorksheetFunction.CountIf(Range(sCol1 & iTRow).Resize(1, 3), "1")
Range(sCol2 & iTRow).Offset(0, 1).Value = WorksheetFunction.CountIf(Range(sCol1 & iTRow).Resize(1, 3), "2")
Range(sCol2 & iTRow).Offset(0, 2).Value = 0
If WorksheetFunction.Sum(Range(sCol2 & iTRow).Resize(1, 2)) > 0 Then
Range(sCol2 & iTRow).Offset(0, 2).Value = Range(sCol2 & iTRow).Value / WorksheetFunction.Sum(Range(sCol2 & iTRow).Resize(1, 2))
Else
Range(sCol2 & iTRow).Resize(1, 3) = ""
End If
For x = IIf(iCol < 25, 41, 55) To IIf(iCol < 25, 50, 64) Step 3
iTotal = iTotal + CInt(Cells(iTRow, x)) + CInt(Cells(iTRow, x + 1))
iTot = iTot + Cells(iTRow, x)
Next
Range(IIf(iCol < 25, "BA", "BO") & iTRow).Value = 0
If iTotal > 0 Then Range(IIf(iCol < 25, "BA", "BO") & iTRow).Value = iTot / iTotal
'
Range("K" & Target.Row).Select
End If
End If
'
Application.ScreenUpdating = True
'
End SubA tester, comme on dit...
A+
Salut tout le monde,
petites améliorations sans réelle importance autre que visuelle...
A+
Bonjour
C'est un travail exceptionnel, félicitation et encore merci : je vais le tester avec mes 45 onglets. Je vous tiens au courant
Encore merci !!!!!
re bonjour,
Pouvez vous m'expliquer votre programme qui maintenant s’exécute avec une vitesse déconcertante afin que je puisse progresser. Je vais copier coller sur mon fichier réel et je vous tiens au courant.
Encore mille merci
Salut cpin,
copier-coller? Les calculs-statistiques ne fonctionneront que si tu valides chaque cellule-couleur en 'P...' en cliquant dessus pour avoir la bonne couleur!
Je redemande : dois-tu filtrer plus que les 'P1', 'P2' et 'P3' que tu as présenté jusqu'ici?
A+
Salut
Oui en fait je filtre de P1 à P17 en sachant que j'ai un P13A et un P13B et que P17 va de P17A à P17H sinon les autres c'est classique P1 P2 P3 P4 etc
En fait je compte copier coller ton programme comme tu me le dis dans les feuilles correspondantes : Dis moi si je dois faire plus
merci de ton aide
A+
Le code actuel ne filtrera que 'P1', 'P2' et 'P3'. C'est facile de changer cela pour prendre les autres en compte mais le temps de traitement risque d'en pâtir.
As-tu d'autres feuilles, n'ayant rien à voir avec le filtrage, dont le nom commence par "P"? Si oui, trouve un autre nom évocateur pour ce(s)(tte) feuille(s).
Donc :
- ne passe pas ton temps à recalibrer chaque cellule-couleur : je vais écrire une macro pour ce faire ;
- je vais réécrire la macro de filtrage pour que ça vole.
Si tu as d'autres précisions importantes, idées, demandes ou autre, transmets maintenant, stp!
A+
Salut,
rectification, ça ne saurait voler plus vite du fait de toutes ces cellules fusionnées... du moins dans l'état actuel de mes connaissances!
La macro de filtrage est corrigée selon la situation réelle décrite et si d'autres feuilles commençant par "P" et n'ayant rien à voir avec le filtrage ont bien été renommées.
Macro à copier-coller dans le module de 'Filtre'.
Précision : j'ose croire et espérer que TOUTES les feuilles 'P...' ont STRICTEMENT la même structure!
Private Sub Worksheet_Change(ByVal Target As Range)
'
Dim tData
Dim sData As String, sNom As String, sSheet As String
'
Application.EnableEvents = False
Application.ScreenUpdating = False
'
If Not Intersect(Target, Range("D6")) Is Nothing Then 'si changement en [D6]
sNom = Target 'sData = nom
iRow = Range("D" & Rows.Count).End(xlUp).Row 'fond de la colonne [C] pour nettoyage...
If iRow > 24 Then '... si c'est déjà rempli
Range("A25:F" & iRow).ClearContents
Range("G25:R" & iRow).Interior.Color = xlNone
Range("A25:R" & iRow).Borders.LineStyle = xlNone
End If
iRow = 24
'préparation pour nouvel affichage
For x = 1 To Sheets.Count
If Left(Sheets(x).Name, 1) = "P" Then
sSheet = Sheets(x).Name 'choix des feuilles à scanner...
With Worksheets(sSheet)
For y = 4 To .Range("K" & Rows.Count).End(xlUp).Row '... jusqu'au fond de la colonne [K]
If Right(.Cells(y, 11), 1) <> Chr(10) Then sData = .Cells(y, 11) & Chr(10)
tData = Split(sData, Chr(10))
If InStr(sData, sNom) > 0 Then 'si cellule contient sNom
For k = 13 To 24
If .Cells(y, k).Interior.Color = RGB(255, 0, 0) Then
iRow = iRow + 1 'ligne d'affichage
Cells(iRow, 3) = sSheet & " - " & y 'nom feuille + ligne
Cells(iRow, 4) = sNom 'nom
For Z = 5 To 6
If .Range(IIf(Z = 5, "D", "J") & y).MergeCells Then
Cells(iRow, Z) = .Range(IIf(Z = 5, "D", "J") & y).MergeArea.Cells(1, 1)
Else
Cells(iRow, Z) = .Range(IIf(Z = 5, "D", "J") & y).Value 'risque
End If
Next
For Z = 1 To 12 'couleurs
Cells(iRow, 6 + Z).Interior.Color = .Cells(y, 12 + Z).Interior.Color
Next
If UBound(tData) > 1 Then
For Z = 0 To UBound(tData) - 1
If tData(Z) <> sNom Then
iRow = iRow + 1
Cells(iRow, 4) = tData(Z)
End If
Next
End If
Exit For
End If
Next
End If
Next
End With
End If
Next
iRow = Range("D" & Rows.Count).End(xlUp).Row
If iRow > 24 Then Range("C25:R" & iRow).Borders.LineStyle = xlContinuous
End If
'
Application.ScreenUpdating = True
Application.EnableEvents = True
'
End SubLa suite plus tard sauf si tu as décidé de procéder manuellement (mais j'en doute!) au calibrage couleur de chacune de tes cellules-couleur...
A+
Hello !
Bel exemple de mastur......ion intellectuelle qui fait du bien ! j'aime beaucoup les exercices de ce genre.
Mais pour la maintenance, revenons un peu sur terre ... et sans délirer !
C'est quoi le besoin ?
Qu'est-ce qui justifie 45 onglets ?
Ne doit-on pas :
- faire une base de données ?
- faire un filtre élaboré ?
- un TCD ?
- des MFC ?
Salut Steelson,
puisque les infos arrivent au compte-goutte, d'abord le plaisir de coder! Pas très long!
Quand nous aurons, peut-être..., le fichier complet et les précisions quant à l'évolution annuelle des données, on pourra vraiment décider.
Quelques lignes en plus, mon Dieu...
A+
Re bonjour
Le fichier que j'ai copié est un extrait de mon fichier il s'agit des trois premier onglets que j'ai anonymisé. Voulez vous le fichier complet qu'il faut que j'anonymise en totalité si cela peut vous aider, les trois premiers onglets représentent un tiers du fichier complet.
Si besoin je peux le faire si çà doit vous faciliter le travail
A+