Synchronisation de plusieurs feuilles d'un classeur pour registre d'actions

Question

Bonjour le forum,

J'essaye de mettre en place un registre d'actions associé à des fiches de risques (FDR). Dans l'idée le registre d'actions dans l'onglet "Actions register" vient "scanner" (à travers le bouton "Actualiser registre") les autres onglets, qui correspondent à des FDR, pour venir extraire les actions listées dans chaque onglets. Dans chaque FDR (une par onglet) le plan d'action se trouve toujours à partir de la ligne 79 vers le bas (en fonctions du nombre d'actions) et des colonnes A à Q. Le scanning permettrait donc de mettre à jour les actions en fonctions des modifications dans chaque FDR (ajout ou suppression d'actions). Pour chaque actions extraites des FDR il y a dans l'onglet "Action register" le code, le titre, le pilote ainsi que la criticité de la FDR à laquelle elle appartient. Ces informations se retrouvent toutes aux mêmes endroit dans chaque FDR.

J'ai tenté quelques manips mais c'est sans espoir de ma part. C'est pour cela que je vous sollicite afin de recueillir vos propositions. En PJ vous trouverez le fichier vierge si vous voulez tenter vos chances.

Merci en avance et bonne journée.

25registre-actions-v1.xlsx (54.23 Ko)

.

Invité · Answer

Intéressant comme FDR Voici le fichier avec un code qui devrait bien se comporter (à tester) A+...

Invité · Answer

Franchement, je ne sais pas, mais il y a toujours moyen d'optimiser le code Déjà fait pour les valeurs des 16 colonnes de la FDR à mettre à jour Bonne remarque, je suis passé à côté Le code à été modifié dans ce sens, une boucle ce n'est jamais long A+...

Invité · Answer

Pour le module 3, voici un code possible à tester 'Macro pour le registre des FDR Sub ScanFDR2() Dim ShtRR As Worksheet, Sht As Worksheet Dim Col As Long, dCol As Long, dLig As Long, Lig As Long, LigRR As Long, LigSup As Long Dim sNumAction As String, sCel As String ' Pour essayer de gagner du temps ' Désactiver le calcul auto et les évènements Application.Calculation = xlCalculationManual Application.EnableEvents = False ' Définir la feuille sur laquelle importer les données Set ShtRR = ThisWorkbook.Sheets("REGISTRE RISQUE TEST") ' Pour chaque feuille du classeur For Each Sht In ThisWorkbook.Sheets ' Vérifier s'il sagit d'une FDR If InStr(1, Sht.Name, "FDR") = 0 Then GoTo SuiteSht ' Vérifier si le nom de la feuille contient "Item" If InStr(1, Sht.Name, "item", vbTextCompare) &gt; 1 Then GoTo SuiteSht ' Dernière ligne remplie de la colonne B de la feuille à traiter ' Cette contient uniquement : FDR-X dLig = Sht.Range("B" & Rows.Count).End(xlUp).Row ' ' 1) Commencer par supprimer les lignes qui doivent l'être ' En parcourant les lignes à partir de la fin For LigSup = ShtRR.Range("A" & Rows.Count).End(xlUp).Row To 4 Step -1 ' Si la ligne est celle de la FDR sur laquelle on va travailler ' et que l'action n'existe pas If ShtRR.Range("A" & LigSup) = Sht.Name And _ WorksheetFunction.CountIf(Sht.Range("B80:B" & dLig), ShtRR.Range("J" & LigSup)) = 0 Then ShtRR.Rows(LigSup).Delete End If Next LigSup ' ' 2) On continue par mettre à jours les lignes ' Pour chaque ligne For Lig = 80 To dLig ' Faire la mise à jour sNumAction = Sht.Range("B" & Lig) LigRR = LigFindNA(ShtRR, sNumAction) ' Si aucune ligne trouvée If LigRR = 0 Then ' Créer une nouvelle ligne LigRR = ShtRR.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row ShtRR.Rows("4:4").Copy Destination:=ShtRR.Range("A" & LigRR) Application.CutCopyMode = False ShtRR.Rows(LigRR).ClearContents End If ' Nombre de colonnes à remplir dCol = ShtRR.Cells(4, Columns.Count).End(xlToLeft).Column ' Remplir la ligne For Col = 1 To dCol ' Récupérer la cellule à remplir en fonction de la colonne sCel = ShtRR.Cells(2, Col) ' Si aucune référence ou dernier caractère pas numérique = pas une référence, on passe à la suite If sCel = "" Or Not IsNumeric(Right(sCel, 1)) Then GoTo SuiteCol ' Si ce n'est pas une colonne "Criticité" If InStr(1, ShtRR.Cells(4, Col), "Criticité", vbTextCompare) = 0 Then ShtRR.Cells(LigRR, Col).Value = Sht.Range(sCel).Value Else ShtRR.Cells(LigRR, Col).Interior.Color = Sht.Range(sCel).DisplayFormat.Interior.Color End If ' Si colonne "Famille" =&gt; Inscrire la formule du lien hypertexte If InStr(1, ShtRR.Cells(4, Col), "Famille", vbTextCompare) &gt; 0 Then With ShtRR.Cells(LigRR, Col) .NumberFormat = "General" .FormulaLocal = "=LIEN_HYPERTEXTE(""&#91;" & ThisWorkbook.Name & "&#93;'" & Sht.Name & "'!$C$6"";" & Chr(34) & Sht.Range("B" & Lig) & Chr(34) & ")" ' Remettre la bonne Police With .Font .Name = "Calibri" .Size = 10 End With End With End If SuiteCol: Next Col Next Lig SuiteSht: Next Sht ' Réactiver le calcul auto et les évènements Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True ' Effacer les variables objet Set Sht = Nothing: Set ShtRR = Nothing End Sub ' Fonction pour trouver la ligne du numéro d'action Function LigFindNA(ShtS As Worksheet, sNumAct As String) Dim CelF As Range ' Rechercher la valeur Set CelF = ShtS.Range("J:J").Find(What:=sNumAct, LookIn:=xlValues, LookAt:=xlWhole, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False) If Not CelF Is Nothing Then LigFindNA = CelF.Row Else LigFindNA = 0 End If End Function A+ Edit : code modifié 03/06 15h25...

Invité · Answer

Si vous faites des blagues aussi Dans la ligne 2, vous avez du texte au lieu de référence, il faut donc ajouter un test Si aucune référence ou dernier caractère pas numérique = pas une référence, on passe à la suite If sCel = "" Or Not IsNumeric(Right(sCel, 1)) Then GoTo SuiteCol Pour le lien hypertexte, il faut remplacer par .FormulaLocal = "=LIEN_HYPERTEXTE(""&#91;" & ThisWorkbook.Name & "&#93;'" & Sht.Name & "'!$C$6"";" & Chr(34) & Sht.Range("B" & Lig) & Chr(34) & ")" De plus en colonne P, vous avez "C&#91;ESPACE&#93;49" au lieu de "C49", renseignez correctement vos références de cellule A+...