Microsoft 365 Mise en forme d'une cellule par rechercheV en VBA

Florent6744 · 4 Octobre 2022

Bonjour,

J'ai besoin de votre aide.
Je souhaite automatiser un repérage de RAL en affichant la couleur dans un TCD par rechercheV.

Plus en détail, quand je suis sur l'onglet RAL mon TCD indique les couleur du matériel connu avec le numéro de RAL (ou une info couleur quand ce n'est pas précis ex: GRIS).
Ce que j'aimerais c'est qu'à partir d'un bouton je puisse afficher dans la colonne C la mise en forme de la cellule correspondant au numéro de RAL de la colonne A.
La référence se trouvant dans l'onglet RefRAL.

Pour info, le vrai tableau contient plusieurs milliers de lignes.

Merci d'avance pour votre aide.

J’espère avoir été assez clair sur ma demande.

Florent

mapomme · 4 Octobre 2022

Bonjour @Florent6744,

Un essai en VBA. Cliquer sur le bouton Hop! Le code est dans module1:

VB:

Sub Test()
Dim xrg, xArea, x, rech
   Application.ScreenUpdating = False
   Columns(3).Clear
   ActiveSheet.PivotTables("Tableau croisé dynamique1").PivotFields("CD_EMPRISE"). _
      ShowDetail = True
   ActiveSheet.PivotTables("Tableau croisé dynamique1").PivotSelect _
      "lu_couleur[All]", xlLabelOnly + xlFirstRow, True
   Set xrg = Selection
   On Error Resume Next
   For Each xArea In xrg.Areas
      For Each x In xArea
         rech = Application.Match(x, Sheets("RefRal").Columns(1), 0)
         If IsError(rech) Then
            Cells(x.Row, "c") = x.Value
         Else
            Cells(x.Row, "c").Interior.Color = Sheets("RefRal").Cells(rech, "b").Interior.Color
         End If
      Next x
   Next xArea
   On Error GoTo 0
   Range("c1").EntireColumn.HorizontalAlignment = xlVAlignCenter
   Range("c1").EntireColumn.AutoFit
   Range("a1").Select
End Sub

mapomme · 4 Octobre 2022

Re,

Une version v2 qui n'utilise plus la couleur de fond de la colonne B de la feuille RefRAL.
On utilise directement le code en hexadécimal (colonne C) qu'on convertit en valeur RGB grâce à la fonction HexaRGB (c'est plus sûr)

Le code:

VB:

Sub Test()
Dim xrg, xArea, x, rech
   Application.ScreenUpdating = False
   Columns(3).Clear
   Columns(3).Font.Size = 8
   ActiveSheet.PivotTables("Tableau croisé dynamique1").PivotFields("CD_EMPRISE"). _
      ShowDetail = True
   ActiveSheet.PivotTables("Tableau croisé dynamique1").PivotSelect _
      "lu_couleur[All]", xlLabelOnly + xlFirstRow, True
   Set xrg = Selection
   On Error Resume Next
   For Each xArea In xrg.Areas
      For Each x In xArea
         rech = Application.Match(x, Sheets("RefRal").Columns(1), 0)
         If IsError(rech) Then
            Cells(x.Row, "c") = x.Value
         Else
            Cells(x.Row, "c").Interior.Color = HexaRGB(Sheets("RefRal").Cells(rech, "c"))
         End If
      Next x
   Next xArea
   On Error GoTo 0
   Range("c1").EntireColumn.HorizontalAlignment = xlVAlignCenter
   Range("c1").EntireColumn.AutoFit
   Range("a1").Select
End Sub

Function HexaRGB(ByVal Hex As String)
Dim R, G, B
   Hex = Right$("000000" & Replace(Hex, "#", ""), 6)
   R = Val("&H" & Mid(Hex, 1, 2))
   G = Val("&H" & Mid(Hex, 3, 2))
   B = Val("&H" & Mid(Hex, 5, 2))
   HexaRGB = RGB(R, G, B)
End Function

Florent6744 · 6 Octobre 2022

Bonjour,

Merci pour ton aide.
Ca fonctionne super bien.
Je montre ca a ma collegue et je te contact s'il y a une modif a réalisé mais a priori tout est ok.

Merci beaucoup.

Microsoft 365 Mise en forme d'une cellule par rechercheV en VBA

Florent6744

XLDnaute Nouveau

Pièces jointes

mapomme

XLDnaute Barbatruc

Pièces jointes

mapomme

XLDnaute Barbatruc

Pièces jointes

Florent6744

XLDnaute Nouveau

Discussions similaires