Simplifier le code

Ilino · 21 Décembre 2014

Forum Bonsoir
je souhaite simplifier le code ci dessous

Code:

'Renvoer a la ligne automatiquement cellule fusionnées
Set t = Intersect(Target, [E13:X13]) ' objet
If Not t Is Nothing Then Ajustement t, [E:X], [E:X], xlCenter 'IMPORTANT : ci dessus la fonction Ajustement

'Réserves 20
Set t = Intersect(Target, [B25:X25])
If Not t Is Nothing Then Ajustement t, [B:X], [B:X], xlLeft 'IMPORTANT : ci dessus la fonction Ajustement
Set t = Intersect(Target, [B26:X26])
If Not t Is Nothing Then Ajustement t, [B:X], [B:X], xlLeft 'IMPORTANT : ci dessus la fonction Ajustement
Set t = Intersect(Target, [B27:X27])
If Not t Is Nothing Then Ajustement t, [B:X], [B:X], xlLeft 'IMPORTANT : ci dessus la fonction Ajustement
Set t = Intersect(Target, [B28:X28])
If Not t Is Nothing Then Ajustement t, [B:X], [B:X], xlLeft 'IMPORTANT : ci dessus la fonction Ajustement
Set t = Intersect(Target, [B29:X29])
If Not t Is Nothing Then Ajustement t, [B:X], [B:X], xlLeft 'IMPORTANT : ci dessus la fonction Ajustement
Set t = Intersect(Target, [B30:X30])
If Not t Is Nothing Then Ajustement t, [B:X], [B:X], xlLeft 'IMPORTANT : ci dessus la fonction Ajustement
Set t = Intersect(Target, [B31:X31])
If Not t Is Nothing Then Ajustement t, [B:X], [B:X], xlLeft 'IMPORTANT : ci dessus la fonction Ajustement
Set t = Intersect(Target, [B32:X32])
If Not t Is Nothing Then Ajustement t, [B:X], [B:X], xlLeft 'IMPORTANT : ci dessus la fonction Ajustement
Set t = Intersect(Target, [B33:X33])
If Not t Is Nothing Then Ajustement t, [B:X], [B:X], xlLeft 'IMPORTANT : ci dessus la fonction Ajustement
Set t = Intersect(Target, [B34:X34])
If Not t Is Nothing Then Ajustement t, [B:X], [B:X], xlLeft 'IMPORTANT : ci dessus la fonction Ajustement
Set t = Intersect(Target, [B35:X35])
If Not t Is Nothing Then Ajustement t, [B:X], [B:X], xlLeft 'IMPORTANT : ci dessus la fonction Ajustement
Set t = Intersect(Target, [B36:X36])
If Not t Is Nothing Then Ajustement t, [B:X], [B:X], xlLeft 'IMPORTANT : ci dessus la fonction Ajustement
Set t = Intersect(Target, [B37:X37])
If Not t Is Nothing Then Ajustement t, [B:X], [B:X], xlLeft 'IMPORTANT : ci dessus la fonction Ajustement
Set t = Intersect(Target, [B38:X38])
If Not t Is Nothing Then Ajustement t, [B:X], [B:X], xlLeft 'IMPORTANT : ci dessus la fonction Ajustement
Set t = Intersect(Target, [B39:X39])
If Not t Is Nothing Then Ajustement t, [B:X], [B:X], xlLeft 'IMPORTANT : ci dessus la fonction Ajustement
Set t = Intersect(Target, [B40:X40])
If Not t Is Nothing Then Ajustement t, [B:X], [B:X], xlCenter 'IMPORTANT : ci dessus la fonction Ajustement
Set t = Intersect(Target, [B41:X41])
If Not t Is Nothing Then Ajustement t, [B:X], [B:X], xlCenter 'IMPORTANT : ci dessus la fonction Ajustement
Set t = Intersect(Target, [B42:X42])
If Not t Is Nothing Then Ajustement t, [B:X], [B:X], xlCenter 'IMPORTANT : ci dessus la fonction Ajustement
Set t = Intersect(Target, [B43:X43])
If Not t Is Nothing Then Ajustement t, [B:X], [B:X], xlCenter 'IMPORTANT : ci dessus la fonction Ajustement
Set t = Intersect(Target, [B44:X44])
If Not t Is Nothing Then Ajustement t, [B:X], [B:X], xlCenter 'IMPORTANT : ci dessus la fonction Ajustement

GRAZIE

eriiic · 21 Décembre 2014

Re : Simplifier le code

Bonjour,

A tester, en l'absence de fichier :

Code:

'Réserves 20
    Set t = [B25:X25]
    For i = 0 To 20
        Set t2 = Intersect(Target, t.Offset(, i))
        If Not t2 Is Nothing Then Ajustement t2, [B:X], [B:X], xlLeft    'IMPORTANT : ci dessus la fonction Ajustement
    Next i

eric

job75 · 21 Décembre 2014

Re : Simplifier le code

Bonsoir Ilino, eriiiic,

Comme ceci on est sûr de ne pas se tromper :

Code:

Dim t As Range, r As Range
'-------
'Réserves 20
For Each r In [B25:X44].Rows
  Set t = Intersect(Target, r)
  If Not t Is Nothing Then Ajustement t, [B:X], [B:X], IIf(r.Row < 40, xlLeft, xlCenter)
Next

Bonne nuit.

Ilino · 22 Décembre 2014

Re : Simplifier le code

Forum BONJOUR, eric BONJOUR, MAITRE bonjour
sans doute
problème résolut
grazie

Simplifier le code

Ilino

XLDnaute Barbatruc

eriiic

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Ilino

XLDnaute Barbatruc

Discussions similaires