XL 2010 adapter une macro sur la feuille active

arvin

XLDnaute Occasionnel
bonjour à tous, grâce au forum la macro suivante colorier un mot en fonction d'une liste (si le mot appartient à une liste alors il colorie le mot)
je souhaiterai maintenant adapter cette macro en
-prenant en compte la feuille active
- la liste est sur une autre feuille
ci joint les explications dans le code VBA du fichier
merci à tous
 

Pièces jointes

  • color 2021.xls
    37.5 KB · Affichages: 13

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Arvin,
Un essai en PJ avec :
VB:
Sub essai()
    Dim plage As Range, Z%, cell As Range
    Application.ScreenUpdating = False
    Set F = Sheets("test")
    For Z = 3 To 33
        For Each cell In ActiveSheet.Range("F1:K10")
            If cell.Value = F.Cells(Z, 2).Value Then cell.Interior.Color = F.Cells(Z, 2).Interior.Color
            If cell.Value = F.Cells(Z, 2).Value Then cell.Font.Color = F.Cells(Z, 2).Font.Color
        Next cell
    Next Z
End Sub
 

Pièces jointes

  • color 2021.xls
    42 KB · Affichages: 3

job75

XLDnaute Barbatruc
Bonjour arvin, sylvanu, soan,

Puisque pour chaque mot on colore tout d'un seul coup ceci devrait être plus rapide :
VB:
Sub essai()
Dim P As Range, c As Range
Set P = Sheets("edt").[F1:K10] 'plage à adapter
Application.ScreenUpdating = False
P.Interior.ColorIndex = xlNone 'RAZ
On Error Resume Next 'si aucune SpecialCell
For Each c In Sheets("test").[B:B].SpecialCells(xlCellTypeConstants) 'colonne à adapter
    P.Replace c, "#N/A", xlWhole
    P.SpecialCells(xlCellTypeConstants, 16).Interior.Color = c.Interior.Color
    P.Replace "#N/A", c
Next
End Sub
PS : il y avait un espace superflu en H6 à droite de rené, je l'ai supprimé.

A+
 

Pièces jointes

  • color 2021(1).xls
    43.5 KB · Affichages: 3

soan

XLDnaute Barbatruc
Inactif
@arvin (bonjour job75)

sur ton autre sujet, où tu as évoqué le même problème qu'ici, tu as écrit :

« réussi ! mais je souhaite adapter la macro à la feuille active »



je crois que tu as oublié de cliquer sur le lien bleu de mon post#3,​
alors je mets ici mon code VBA (non testé) :

VB:
Option Explicit

Sub essai()
  Dim cel1 As Range, cel2 As Range, Z As Byte
  Application.ScreenUpdating = 0
  For Z = 3 To 33
    Set cel1 = Cells(Z, 2)
    For Each cel2 In [F1:K10]
      If cel2 = cel1 Then
        cel2.Interior.Color = cel1.Interior.Color
        cel2.Font.Color = cel1.Font.Color
      End If
    Next cel2
  Next Z
End Sub

si tu as plus de 255 lignes, alors pour la ligne Dim, au lieu de Z As Byte
met : Z As Long ou plus simplement : Z&

soan
 

job75

XLDnaute Barbatruc
Au post #4 je ne copiais que les couleurs de fond car c'est tout ce qu'il y avait à copier dans votre fichier.

Maintenant s'il y a en plus des couleurs de police à copier voyez ce fichier (2) :
VB:
Sub essai()
Dim P As Range, c As Range
Set P = Sheets("edt").[F1:K10] 'plage à adapter
Application.ScreenUpdating = False
P.Interior.ColorIndex = xlNone 'RAZ couleur fond
P.Font.ColorIndex = xlAutomatic 'RAZ couleur police
On Error Resume Next 'si aucune SpecialCell
For Each c In Sheets("test").[B:B].SpecialCells(xlCellTypeConstants) 'colonne à adapter
    P.Replace c, "#N/A", xlWhole
    With P.SpecialCells(xlCellTypeConstants, 16)
        .Interior.Color = c.Interior.Color
        .Font.Color = c.Font.Color
    End With
    P.Replace "#N/A", c
Next
End Sub
 

Pièces jointes

  • color 2021(2).xls
    43.5 KB · Affichages: 1

job75

XLDnaute Barbatruc
Dans le fichier joint les 3 solutions sont comparées sur la plage F1:K1000, chez moi :

- sylvanu 11,2 seconde

- soan 8,2 seconde

- job75 0,03 seconde.
 

Pièces jointes

  • Comparaison color(1).xls
    99 KB · Affichages: 4

soan

XLDnaute Barbatruc
Inactif
@job75

Dans le fichier joint les 3 solutions sont comparées sur la plage F1:K1000, chez moi :

- sylvanu 11,2 seconde

- soan 8,2 seconde

- job75 0,03 seconde.

donc le grand gagnant est :

job75, avec 0,03 seconde ! 🥳 🥇 🏆 🍾



remarque, dans la Charte du site XLD, c'est bien précisé qu'il n'y a aucune urgence, hein ?
donc si un code VBA met plus longtemps qu'un autre à s'exécuter, c'est pas grave ! 🤣


soan 😜
 

soan

XLDnaute Barbatruc
Inactif
@job75

ben dis-donc ! tu dois avoir un super PC ! 🤩

car sur le mien qui a un i5-3450 @ 3.10 GHz, une RAM 8 Go,
Windows 7, et Excel 2007, j'ai ces temps :

- sylvanu : 20,46 ; puis 20,43 secondes

- soan : 17,65 ; puis 17,32 secondes

- job75 : 75 secondes ... euh, non : 0,07 ; puis 0,04 seconde

conclusion : yeepeeeeeh ! c'est encore et toujours job75
le grand gagnant du tournoi ! 😄

soan
 

Discussions similaires

Réponses
4
Affichages
410
Réponses
9
Affichages
363