Problème pour insérer une formule dans un code VBA

Version imprimable

Bonjour,

Grâce au forum CCM, je dispose d'un code pour effectuer un filtre élaboré. Ce code fonctionne très bien, et je remercie à nouveau les membres de CCM qui m'ont aidé. Mon pb aujourd'hui est que j'ai voulu rajouté une ligne me permettant d'appliquer une formule à la colonne K, cette formule renvoie une valeur en fonction des éléments du filtre (qui est copié sur les colonnes de B à J). La formule à appliquer se trouve en K2, et elle doit s'appliquer de la cellule K7 jusqu'à la dernière ligne du filtre (qui est amenée à évoluer). Malheureusement j'ai trop de lacunes en VBA, ce code ne fonctionne pas, je n'ai aucun message d'erreur mais la formule ne s'applique pas...

J'ai vraiment besoin de votre aide, merci à tous ceux qui voudront bien se pencher sur mon pb...

Voici mon code :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 Sub FiltreAvance() Dim DL As Integer Dim DerLig As Integer DL = Sheets(1).Cells(Application.Rows.Count, 4).End(xlUp).Row DerLig = Sheets(2).Cells(Application.Rows.Count, 2).End(xlUp).Row With Sheets(1) .Select .Range(Cells(4, 1), Cells(DL, 9)).Select End With Selection.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets(2).[B1:B2], CopyToRange:=Sheets(2).[B6], Unique:=False With Sheets(2) .Select Range("B6:J6").Font.Bold = True Range("B6:J6").Font.Size = 16 Range("B6:J6").Font.ColorIndex = 2 Range("B6:J6").Interior.ColorIndex = 41 Range("B6:J6").HorizontalAlignment = xlCenter Range("F7:J65536").HorizontalAlignment = xlCenter Range("B7:E65536").HorizontalAlignment = xlLeft .Range("K7" & DerLig).FormulaR1C1 = Range("K2").FormulaR1C1 End With End Sub

Bonjour,

regarde si c'est une bonne piste, je n'ai pas pu la tester bien entendu

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
Sub FiltreAvance()
Dim Plage As Range
 
With Sheets(1)
    Set Plage = .Range(.Cells(4, 1), .Cells(.Cells(.Rows.Count, 4).End(xlUp).Row, 9))
    Plage.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets(2).[B1:B2], CopyToRange:=Sheets(2).[B6], Unique:=False
End With
 
With Sheets(2)
    With .Range("B6:J6")
        .Font.Bold = True
        .Font.Size = 16
        .Font.ColorIndex = 2
        .Interior.ColorIndex = 41
        .HorizontalAlignment = xlCenter
    End With
 
    .Range("F7:J65536").HorizontalAlignment = xlCenter
    .Range("B7:E65536").HorizontalAlignment = xlLeft
    Set Plage =  .Range(.Cells(7, 11), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 11))
    Plage.FormulaR1C1 = .Cells(2, 11).FormulaR1C1
End With
 
End Sub

Je me suis permis de virer les Select et d'enlever tes variables contenant les dernières lignes
pour une meilleur lisibilité, j'ai par contre utilisé une variable Plage sur le filtre avancé et l'écriture de la formule

Ca fonctionne

J'ai intégré ton code et il a l'air de très bien fonctionner ! Merci beaucoup.

J'ai voulu en profiter pour le réutiliser pour un autre code (un code qui efface le contenu de certaines plage de cellules), malheureusement je n'ai pas du l'adapter comme il faut car il ne marche pas... j'ai le message d'erreur : Variable non définie
Code:

1 2 3 4 5 6 7 8 9 10 Sub Effacer() Dim Plage1 As Range Dim Plage2 As Range With Sheets(2) Plage1 = .Range(.Cells(6, 2), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 9)) Plage1.ClearContents Plage2 = .Range(.Cells(7, 10), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 39)) Plage2.ClearContents End With End Sub
As tu une idée de ce qui ne va pas ?

Merci pour ton aide.

21/07/2015, 14h21
joe.levrai

Une variable Objet (Variable Range) s'instancie au moyen de l'instruction Set

par exemple

Code:

Set Plage = Feuil1.Range("A1")
21/07/2015, 14h49
ti_mouton

Super ça fonctionne, merci beaucoup j'aurais appris des choses grâce à toi.

Je me permets de te solliciter à nouveau si tu le veux bien. Cette macro Effacer prend beaucoup de temps ( au moins 5-6min), je voulais savoir si tu connais un autre type de code, qui serait peut etre plus rapide? De plus, actuellement j'ai deux boutons, je dois d'abord cliquer sur le bouton 1 qui active la macro Effacer, puis je clique sur le bouton 2 qui active ma macro FiltreAvance. Y aurait il un moyen pour regrouper les 2 macros ? l'idéal serait que lorsqu'on clique sur le bouton 2, la macro efface le contenu des 2 plages de cellules mentionnées pour ensuite copie le nouveau filtre et lance l'exécution des formules.

Merci beaucoup pour ton aide.
21/07/2015, 15h45
joe.levrai

A vrai dire, j'ai l'impression qu'on peut encore faire mieux dans une seule procédure :

1) Effacement de la totalité de ta feuille de destination
2) écriture de la zone de critère et des en-têtes où tes données seront copiées par le filtre
3) application du filtre

ça paraît radical, mais au moins le nettoyage de feuille va prendre moins d'une seconde
21/07/2015, 15h56
ti_mouton

Je ne comprend pas bien, selon toi il ne faut pas passer par VBA ? le soucis c'est qu'à la suite de mon filtre j'ai une dizaine de colonne avec des valeurs calculées grâce aux formules que je renseigne en ligne 2 ... Si j'efface toute ma feuille manuellement et que je réecri tout ça n'est pas très pratique...

Non, ma proposition était intégralement géré dans une seule procédure VBA

cependant, mon impression était fausse car tu as d'autres données que tu souhaites visiblement conserver

ton explication répond à la question : pourquoi c'est si long

si tu as des tonnes de formules, c'est peut être le recalcule de la feuille qui ralenti le processus ?

essaye ainsi, j'en ai profité pour tout rassembler dans une seule procédure :

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
Sub EffaceEtFiltre()
Dim Plage As Range
 
'neutralise le recalcule
Application.Calculation = xlCalculationManual
With Sheets(2)
    ' regroupement de tes deux plages dans une seule
    Set Plage = Union(.Range(.Cells(6, 2), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 9)), .Range(.Cells(7, 10), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 39)))
 
    'effacement des deux plage
    Plage.ClearContents
End With
'remise en place du recalcule automatique
Application.Calculation = xlCalculationAutomatic
 
' partie liée au filtre avancé
With Sheets(1)
    Set Plage = .Range(.Cells(4, 1), .Cells(.Cells(.Rows.Count, 4).End(xlUp).Row, 9))
    Plage.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets(2).[B1:B2], CopyToRange:=Sheets(2).[B6], Unique:=False
End With
 
With Sheets(2)
    With .Range("B6:J6")
        .Font.Bold = True
        .Font.Size = 16
        .Font.ColorIndex = 2
        .Interior.ColorIndex = 41
        .HorizontalAlignment = xlCenter
    End With
 
    .Range("F7:J65536").HorizontalAlignment = xlCenter
    .Range("B7:E65536").HorizontalAlignment = xlLeft
    Set Plage = .Range(.Cells(7, 11), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 11))
    Plage.FormulaR1C1 = .Cells(2, 11).FormulaR1C1
End With
 
End Sub

21/07/2015, 16h28
ti_mouton

Ah ok, pardon je t'avais mal compris.

Je viens d'essayer ton code, le filtre marche bien, seul pb mes formules (inscrites dans les cellules de K2 à AN2) ont été effacées aussi du coup je n'ai plus mes valeur calculées.

Pourtant les plages à effacer ont bien été renseignées et n'incluent pas les cellules de K2 à AN2 ... C'est bizzare.

Pour ta question des formules effacées, j'ai peur de ne pouvoir deviner, je ne sans pas comment sont agencées tes données
le comportement provient de ce que contient ta colonne B (c'est sur elle qu'on calcule les lignes dynamiquement)

essaye ce code :
Code:

1 2 3 4 5 6 7 With Sheets(2) ' regroupement de tes deux plages dans une seule Set Plage = Union(.Range(.Cells(6, 2), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 9)), .Range(.Cells(7, 10), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 39))) ' affiche l'adresse de la plage MsgBox Plage.Address End With
et regarde l'adresse de la plage pour vérifier que tes colonnes calculées ne sont pas dedans

21/07/2015, 18h02
ti_mouton

Génialissime ça fonctionne !!! Il y avait en effet une petite erreur au niveau de la plage à effacer, j'étais passé à coté tout à l'heure.

Un très très grand merci pour toute ton aide !