Déplacement dans les cellules

Version imprimable

Bonjour,

J'aimerai simplifier le code ci-dessous

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
 
i = 56
t = 40
Range("N40").Select
For a = 1 To 10
    i = i + 1
    t = t + 1
 
    If Range("B" & i).Font.Color = RGB(255, 0, 0) Then
        Range("N" & t).Interior.ColorIndex = 37
    End If
    If Range("C" & i).Font.Color = RGB(255, 0, 0) Then
        Range("O" & t).Interior.ColorIndex = 37
    End If
    If Range("D" & i).Font.Color = RGB(255, 0, 0) Then
        Range("P" & t).Interior.ColorIndex = 37
    End If
    If Range("E" & i).Font.Color = RGB(255, 0, 0) Then
        Range("Q" & t).Interior.ColorIndex = 37
    End If
    If Range("F" & i).Font.Color = RGB(255, 0, 0) Then
        Range("R" & t).Interior.ColorIndex = 37
    End If
    If Range("G" & i).Font.Color = RGB(255, 0, 0) Then
        Range("S" & t).Interior.ColorIndex = 37
    End If
    If Range("H" & i).Font.Color = RGB(255, 0, 0) Then
        Range("T" & t).Interior.ColorIndex = 37
    End If
    If Range("I" & i).Font.Color = RGB(255, 0, 0) Then
        Range("U" & t).Interior.ColorIndex = 37
    End If
    If Range("J" & i).Font.Color = RGB(255, 0, 0) Then
        Range("V" & t).Interior.ColorIndex = 37
    End If
    If Range("K" & i).Font.Color = RGB(255, 0, 0) Then
        Range("W" & t).Interior.ColorIndex = 37
    End If
 
    If Range("L" & i).Font.Color = RGB(255, 0, 0) Then
        Range("X" & t).Interior.ColorIndex = 37
    End If
    If Range("M" & i).Font.Color = RGB(255, 0, 0) Then
        Range("Y" & t).Interior.ColorIndex = 37
    End If
    If Range("N" & i).Font.Color = RGB(255, 0, 0) Then
        Range("Z" & t).Interior.ColorIndex = 37
    End If
    If Range("O" & i).Font.Color = RGB(255, 0, 0) Then
        Range("AA" & t).Interior.ColorIndex = 37
    End If
    If Range("P" & i).Font.Color = RGB(255, 0, 0) Then
        Range("AB" & t).Interior.ColorIndex = 37
    End If
    If Range("Q" & i).Font.Color = RGB(255, 0, 0) Then
        Range("AC" & t).Interior.ColorIndex = 37
    End If
    If Range("R" & i).Font.Color = RGB(255, 0, 0) Then
        Range("AD" & t).Interior.ColorIndex = 37
    End If
    If Range("S" & i).Font.Color = RGB(255, 0, 0) Then
        Range("AE" & t).Interior.ColorIndex = 37
    End If
    If Range("T" & i).Font.Color = RGB(255, 0, 0) Then
        Range("AF" & t).Interior.ColorIndex = 37
    End If
 
Next

J'ai essayé d'effectuer avec une deuxième boucle en me déplacent d'une colonne, et cela ne fonctionne pas.

Pourriez-vous m'aider à améliorrer cette codification.

Par avance merci de votre aide.

Bonjour,
essaies ce code et améliores le à tes besoins

Code:

1
2
3
4
5
6
7
8
Dim I As Long, T As Long
For T = 41 To 50
    For I = 2 To 21
        If Cells(T + 16, I).Font.Color = 255 Then
            Cells(T, I + 12).Interior.ColorIndex = 37
        End If
    Next I
Next T

En une seule boucle (pour moins de lignes mais traitement identique)

Code:

1
2
3
4
5
Dim c As Range
Application.ScreenUpdating = False
For Each c In Sheets("Feuil1").Range("B57:T66") 'adapter le nom de la feuille
    c.Offset(-16, 12).Interior.ColorIndex = 37 * Abs(c.Font.Color = 255)
Next c

31/01/2011, 15h53
casefayere

Bonjour mercatog, re le forum, rch05

Je suis obligé de passer ce post pour te dire, mercatog, que tu m'étonneras toujours, aie aie!, j'ai encore du chemin à faire

Bonne journée

PS : par contre, si tu mets

Code:

Application.ScreenUpdating = False

je crois qu'il faut spécifier aux non habitués qu'à la fin du code

Code:

Application.ScreenUpdating = true

j'ai déjà eu des surprises avec cet oubli
31/01/2011, 16h11
MarcelG

Essai sur Range
Bonjour et ravi de te retrouver mercatog,
Bonjour casefayere,

Le code est actif bien entendu.

Au demeurant, j'ai voulu essayer d'appliquer la méthode sur le bloc complet, plutôt que sur les cellules qui le composent.

[
Code:

1 2 3 4 5 6 CODE]Public Sub essai() Application.ScreenUpdating = False With Sheets("Feuil1").Range("B57:T66") .Offset(-16, 12).Interior.ColorIndex = 37 * Abs(.Font.Color = 255) End With End Sub
[/CODE]

Sans résultat. Sinon tu y aurais pensé mercatog, j'en suis sûr.
Mais pourquoi.
31/01/2011, 16h11
rch05

Bonjour à tous les 2,

Vous êtes très fort.
J'ai appliqué le code de casefayere et puis celui de mercatog, et cela fonctionne très bien.
Si j'ai bien compris (étant un jeune débutant), il faudrait que mette Application.ScreenUpdating à true à la fin du code.
En regadant l'aide (F1) il le précise.

Chapeau bas messieurs:ccool::ccool:

J'en apprends avec vous sur ce site

Encore une fois merci de vos explications et de votre aide TRES PRECIEUSE

Christian
31/01/2011, 17h29
rch05

Re bonjour messieurs,

Je me suis trop emballé.
En effectuant le test, j'ai remarqué qu'il m'écrasé les cellules non concernées.

Je m'explique:
Si la celulle A1 à le texte en rouge, je mets la cellule AA1 une couleur de font.
Mais là, il écrase la cellule à blanc si le le texte n'est pas en rouge.
Avez-vous une solution?

Christian

Un If suffirait

Code:

1
2
3
4
5
Dim c As Range
Application.ScreenUpdating = False
For Each c In Sheets("Feuil1").Range("B57:T66") 'adapter le nom de la feuille
    If c.Font.Color = 255 then c.Offset(-16, 12).Interior.ColorIndex = 37
Next c

31/01/2011, 18h52
rch05

Merci mercatog,

J'aurai du y penser, mais c'est la fonction Abs qui me gênait.

Un grand merci de ton aide:ccool:

Cordialement
Christian

Code:

1
2
3
For Each c In Sheets("Feuil1").Range("B57:T66") 'adapter le nom de la feuille
    c.Offset(-16, 12).Interior.ColorIndex = 37 * Abs(c.Font.Color = 255)
Next c

est l'équivalent de

Code:

1
2
3
For Each c In Sheets("Feuil1").Range("B57:T66") 'adapter le nom de la feuille
    c.Offset(-16, 12).Interior.ColorIndex = - 37 * (c.Font.Color = 255)
Next c

En effet, la proposition logique (c.Font.Color = 255) = -1 si c'est vrai et 0 si c'est faux
qui est l'équivalent classique de

Code:

1
2
3
4
5
6
7
For Each c In Sheets("Feuil1").Range("B57:T66")   'adapter le nom de la feuille
   If c.Font.Color = 255 Then
      c.Offset(-16, 12).Interior.ColorIndex = 37
   Else
      c.Offset(-16, 12).Interior.ColorIndex = 0
   End If
Next c

Pour ne pas toucher à tes couleurs initiales, il suffit de supprimer ce que fait Else

31/01/2011, 22h20
rch05

Bonsoir mercatog,

Un grand merci de tes explications.
J'ai pris l'option du IF sans Else, car la couleur initiale ne doit pas être touchée.
Mais la fonction ABS, me servira surement.
Maintenant cela fonctionne très bien.

Bonne soirée,
Et surement à bientôt.....:lol:

Cordialement
Christian