Simplification code VBA généré par enregistreur de macro

Version imprimable

Bonjour à toutes et à tous

J'ai utilsé l'enregistreur de macro pour mettre une mise en forme automatique, des lignes, centrer des données et ajouter un motif sur une cellule.
Je trouve que le code généré est long, je me demandais s'il n'y avait pas une manière plus élégante de coder tout ça.

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
69
70
71
72
73
74
75
76
77
78
 ActiveCell.FormulaR1C1 = "M"
    Range("B100").Select
    ActiveCell.FormulaR1C1 = "S"
    Range("B101").Select
    ActiveCell.FormulaR1C1 = "N"
    Range("B99:B101").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Range("B100").Select
    With Selection.Interior
        .ColorIndex = 0
        .Pattern = xlGray8
        .PatternColorIndex = xlAutomatic
    End With
    Range("A99:W101").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With

Merci pour votre aide,

Bonne journée

Ceci suffira?

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
    Range("B99").Value = "M"
    Range("B100").Value = "S"
    Range("B101").Value = "N"
    With Range("B99:B101")
        .HorizontalAlignment = xlCenter
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeRight).Weight = xlThin
        .Borders(xlEdgeTop).Weight = xlThin
        .Borders(xlEdgeBottom).Weight = xlThin
        .Borders(xlInsideVertical).Weight = xlThin
        .Borders(xlInsideHorizontal).Weight = xlThin
    End With
    With Range("A99:W101")
        .Borders(xlEdgeLeft).Weight = xlMedium
        .Borders(xlEdgeRight).Weight = xlMedium
        .Borders(xlEdgeTop).Weight = xlMedium
        .Borders(xlEdgeBottom).Weight = xlMedium
    End With
 
    With Range("B100").Interior
        .ColorIndex = 0
        .Pattern = xlGray8
    End With

10/08/2009, 10h47
altra

D'accord merci à tous les deux.

C'est suffisant pour moi.
10/08/2009, 11h01
diude54

J'ai retiré le mien, celui de mercatog est mieux

Bonjour,

Voyez si ce code vous convient mieux

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
 
Sub aa()
Dim R As Range
Dim i&
[b99] = "M"
[b100] = "S"
[b101] = "N"
Set R = Range("B99:B101")
With R
  .HorizontalAlignment = xlCenter
  On Error Resume Next
  For i& = xlDiagonalDown To xlDiagonalUp
    .Borders(i&).LineStyle = xlNone
  Next i&
  For i& = xlEdgeLeft To xlInsideHorizontal
    With .Borders(i&)
      .LineStyle = xlContinuous
      .Weight = xlThin
      .ColorIndex = xlAutomatic
    End With
  Next i&
  On Error GoTo 0
End With
With [b100].Interior
  .ColorIndex = 0
  .Pattern = xlGray8
  .PatternColorIndex = xlAutomatic
End With
Set R = Range("A99:W101")
With R
  For i& = xlDiagonalDown To xlDiagonalUp
    .Borders(i&).LineStyle = xlNone
  Next i&
  For i& = xlEdgeLeft To xlEdgeRight
    With .Borders(i&)
      .LineStyle = xlContinuous
      .Weight = xlMedium
      .ColorIndex = xlAutomatic
    End With
  Next i&
End With
End Sub

Cordialement.

PMO
Patrick Morange

10/08/2009, 12h05
altra
Re

Merci pour ta proposition PMO.

J'ai juste une autre petite question.
Est ce possible d'assigner à plusieur plage la même mise en forme.
Je pensais marquer quelquechose comme ça, mais visiblement cela ne marche pas
Code:

1 2 3 4 5 6 Set R = Range(Cells(5, 4), Cells(7, 4)) Set R1 = Range(Cells(5, 6), Cells(7, 6)) With R;R1 .Borders(xlEdgeLeft).Weight = xlThin End With
Merci
10/08/2009, 12h20
Krovax

bonjour essaye

Code:

With union(R,R1)

je n'ai pas excel sous la main pour tester du coup je ne sas plus si c'est une , ou un ; je te laisse consulter l'aide
10/08/2009, 12h40
Fvandermeulen
Salut,
Dans ce cas tu peux faire:
Code:

1 2 3 With Range("D5:D7,F5:F7") .Borders(xlEdgeLeft).Weight = xlThin End With
Par contre j'ai jamais essayé avec la "méthode" cells, à voir si c'est utile...

A+
10/08/2009, 13h25
altra
Merci à tous

Code:

union(R,R1)

me convient parfaitement

@Fvandermeulen: ta solution ne fonctionne pas chez moi.
En effet je voudrais voir apparaitre 2 lignes distinctes une de D5 à D7 et la 2nde de F7 à F5 or avec ton code il n'y a que la 1ere.
Je veux utiliser cells pour pouvoir par la suite y mettre quelquechose comme
Code:

1 2 Set R = Range(Cells(i, 4), Cells(i+2, 4)) Set R1 = Range(Cells(i, 6), Cells(i+2, 6))
Il semblerait qu'avec Range cela ne soit pas possible.

Merci pour votre aide.

Bonne journée

Bonjour,

La solution de Fvandermeulen fonctionne. Voici un exemple où la plage ''D5 : D7, F5 : F7'' est colorée en rouge
Code:

1 2 3 4 5 6 7 Sub bb_Fvandermeulen() Dim R As Range Set R = Range("D5:D7,F5:F7") R.Interior.ColorIndex = 3 MsgBox R.Address(False, False) End Sub
Le même résultat (mais colorisation en bleu) est obtenu avec
Code:

1 2 3 4 5 6 7 8 9 10 Sub aa_pmo() Dim R As Range Dim i& i& = 5 Set R = Range(Cells(i&, 4), Cells(i& + 2, 4)) Set R = Application.Union(R, Range(Cells(i, 6), Cells(i + 2, 6))) R.Interior.ColorIndex = 5 MsgBox R.Address(False, False) End Sub
Cordialement.

PMO
Patrick Morange

11/08/2009, 11h47
altra

Bonjour,

Ah oui, effectivement elle fonctionne, j'ai du mal apercevoir la 2nde ligne, au temps pour moi.

Merci bonne journée