XL 2016 Recopier mise en forme depuis une liste

Stephane CLAIN

XLDnaute Nouveau
Bonsoir,

En espérant que cette question n'a pas été encore (j'ai fait des recherches mais je n'ai rien trouvé).

Une fois par semaine, je dois récupérer des données de plusieurs personnes, l'intégrer dans mon classeur et lancer une macro.
A la fin de la macro, je me retrouve notamment avec une colonne qui contient des codes demandeurs (en feuille 1, col A) sans mise en forme.
Dans ma feuille 2, j'ai une liste de demandeurs avec la bonne mise en forme que j'aimerais appliqué à chaque cellule de ma colonne A en fonction du demandeur.
La longueur de la colonne A est comprise variable en fonction des semaines

Avez-vous une une formule ou un bout de code que je pourrais rajouter dans ma macro?

Merci par avance
 

Pièces jointes

  • mise en forme.xlsx
    263.1 KB · Affichages: 24
Dernière édition:

Staple1600

XLDnaute Barbatruc
Bonsoir le fil, le forum

Comme j'ai pondu, je poste ;)
(Ce sera peut-être ici utile ou un jour ailleurs... ;))
VB:
Sub Coloriage()
Dim vArr, vColor, X, i&
vColor = Array(3506772, 13395711, 36799, 7884319, 11573124, 14998742, 10092543, 11389944, 65535, 8696052, 39372, 1137094, 10092543, 14083324)
vArr = Array("I", "T", "TX", "CEM", "C", "EALE", "111", "118", "122", "129", "162", "169", "141", "149")
With Application
    .ScreenUpdating = False
    On Error Resume Next
    For i = 6 To Cells(Rows.Count, 1).End(xlUp).Row
    X = .Index(vColor, .Match(Cells(i, 1).Text, vArr, 0))
    If Not IsError(X) Then
        Cells(i, 1).Interior.Color = CLng(X)
        Cells(i, 1).Font.Bold = -1
    End If
    Next
End With
End Sub

PS: Ce n'est pas parfait ni finalisé mais il est tard et le sommeil me guette.
 

Staple1600

XLDnaute Barbatruc
Re

J'ai revu (et simplifié) ma proposition initiale
VB:
Sub Test_OK()
Dim lig&, j&, ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets(1): Set ws2 = Sheets(2)
lig = ws1.Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = 0
'ici on remplace 4 si la liste ne commence pas en ligne 4
For j = 4 To lig
On Error Resume Next
'ici on remplacera B3:B10 par la plage idoine ou une plage nommée
X = Application.Match(ws1.Cells(j, 1), ws2.Range("B3:B10"), 0)
If Not IsError(X) Then
'ici on a X+2 parce que B3, donc changer en conséquence
ws2.Cells(X + 2, 2).Copy: ws1.Cells(j, 1).PasteSpecial -4122
Application.CutCopyMode = False
End If
Next
End Sub
 

Lone-wolf

XLDnaute Barbatruc
Re Jean Marie

@Staple1600

Comme ceci c'est plus rapide. Sinon chez moi après test de la macro, le fichier est bloqué et suis obligé de le fermer.


@Stephane CLAIN : copie cette macro. Les anciennes bloquent le fichier si la plage est trop grande(test éffectué sur plus de 2000 lignes).

VB:
Option Explicit

Sub Test_OK()
Dim derlig&, j&, ws1 As Worksheet, ws2 As Worksheet, plage As Range, x

    Set ws1 = Sheets(1): Set ws2 = Sheets(2)
    derlig = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    Set plage = ws2.Range("b4:b" & derlig)

    Application.ScreenUpdating = 0
    For j = 6 To derlig
        x = Application.Match(ws1.Cells(j, 1), plage, 0)
        If Not IsError(x) Then               'ici on a x + 3 parce que B4
            ws1.Cells(j, 1).Interior.Color = ws2.Cells(x + 3, 2).Interior.Color
            ws1.Cells(j, 1).Font.Bold = True
        Else
            ws1.Cells(j, 1).Interior.Color = xlNone
            ws1.Cells(j, 1).Font.Bold = False
        End If
    Next j
End Sub


EDIT: désolé Jean Marie :oops:. Merci infiniment pour ton intervention.
 
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
311 735
Messages
2 082 024
Membres
101 873
dernier inscrit
excellllll