Boucle sur MFC et sur condition de la MFC

Citation:

Sauriez-vous écrire le code sans le compteur?

Il suffit de supprimer le For et le Next.
Inutile de refaire x fois la même chose.
eric

Voici avec la possibilité d'ajouter ou de supprimer des gaines et des étages.

Pour la suppression des gaines, j'ai opté pour la suppression de la dernière gaine à chaque clic sur le bouton, à moins que vous préfériez choisir la gaine à supprimer. (On ne peut pas supprimer la première gaine)
Pour la suppression des étages, même procédure, je supprime le dernier étage et refait les formules dans la foulée. (On ne peut pas supprimer le RDC)

Il y aura probablement des ajustements à faire.

Par contre, je n'ai pas trouver de différence entre les formules du RDC et celles des étages intermédiaires.
Pièce jointe 432347

cdlt

Bonjour,

Même fichier avec quelques réajustements
Pièce jointe 432457

Cdlt

Bonjour Arturo!
Désolé de ne revenir que maintenant je n'ai pas eu accès à mon ordinateur hier!!
C'est vraiment super!!
Je suis entrain de regarder le code et d'y faire quelques ajustement. Je vous ferais un retour plus complet cet après midi sur les parties que je n'arrives pas à reprendre...

Cordialement

1 pièce(s) jointe(s)

Alors je vais essayé d'être le plus clair possible. J'ai modifié certaine partie du code (en couleur)
Je n'ai pas mis les sub non concerné par les modifications

Dans le module 1:

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
Sub MFC_Chutes()
    Dim Couleur As Long
    Dim DerLig As Long, DerCol As Long, Col As Long, Compteur As Long
    Dim NbGaines As Long
    Dim NbEtages As Byte
    Dim Plage As Range
    Dim Rng As Excel.Range, Fc As Excel.FormatCondition
    Application.ScreenUpdating = False
    Sheets("Chutes de gaines").Select
 
    'On détermine le nombre d'étages, donné dans la cellule A12
    If [A12] <> "RDC" And [A12] <> 0 Then NbEtages = Replace([A12], "R+", "", 1, 2) Else: NbEtages = 0
 
    DerCol = [XFD2].End(xlToLeft).Column
    DerLig = [A1000].End(xlUp).Column
 
    'on efface les MFC précédentes
    Range(Cells(5, 3), Cells(DerLig, DerCol)).FormatConditions.Delete
 
    'On détermine le nombre de gaines, donné dans la ligne 2
    NbGaines = Application.WorksheetFunction.Max(Rows(2))
 
    'Range("C5:GO134").FormatConditions.Delete 'on efface les MFC précédentes
    DerLig = [A1000].End(xlUp).Row
    Range(Cells(5, "C"), Cells(DerLig, DerCol + 6)).FormatConditions.Delete  'on efface les MFC précédentes
 
    For c = 4 To 8 'N° de la colonne traitée
        'préparation des paramètres en fonction de la colonne traitée
        Select Case c
        Case Is = 4 'MFC EU
            Couleur = RGB(255, 128, 255) 'Couleur à appliquer
            Lig = 9
        Case Is = 5 'MFC EV
            Couleur = RGB(0, 128, 0)
            Lig = 8
        Case Is = 6 'MFC EP
            Couleur = RGB(0, 128, 224)
            Lig = 7
        Case Is = 7 'MFC ECS
            Couleur = RGB(192, 32, 64)
            Lig = 15
        Case Is = 8 'MFC VMC
            Couleur = RGB(160, 64, 255)
            Lig = 12
        End Select
 
        '******************** Application des MFC ***************************
        For Cpt = c To DerCol + 7 Step 7
            Set Rng = Range(Cells(5, Cpt), Cells(DerLig - 9, Cpt)) 'Est-il possible de définir la plage correspondant à un étage pour que la MFC ne decsende pas automatiquement jusqu'au RDC. Il me semble que cela est du au "derlig" ?
            Cells(Lig, Cpt).Select
            Cel = ActiveCell.Address
            Set Fc = Rng.FormatConditions.Add(Type:=xlExpression, Formula1:="=" & Cel & "=1") 'Formule de la MFC
            With Fc.Interior
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent2
                .Color = Couleur
            End With
    Next Cpt, c
End Sub

Module 2 :

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
Sub Conservation_des_Formules() 'Sur 3 niveaux
    Application.ScreenUpdating = False
 
    'Constitution d'un étage
    Etage = Array("Dev", "EP", "WC", "SDB", "Cuisine", "Bouche", "R+10", "Rac souple", "Rac rigide", "ECS")
 
    'formules du dernier étage
    Range("C6").FormulaR1C1 = "=RC[-1]"
    Range("F7").FormulaR1C1 = "=IF(RC[-4],1,0)"
    Range("E8").FormulaR1C1 = "=IF(RC[-3],1,0)"
    Range("D9").FormulaR1C1 = "=IF(OR(RC[-2]=1,R[1]C[-2]=1),1,0)"
    Range("H12").FormulaR1C1 = "=IF(OR(R[-4]C[-6]=1,R[-3]C[-6]=1,R[-2]C[-6]=1,R[11]C=1),1,0)"
    Range("G15").FormulaR1C1 = "=IF(RC[-5]=1,1,0)"
 
    'Formules étages intermédiaires et RDC
    Range("C17").FormulaR1C1 = "=RC[-1]"
    Range("F18").FormulaR1C1 = "=IF(OR(RC[-4]<>0,R[-11]C=1),1,0)"
    Range("E19").FormulaR1C1 = "=IF(OR(RC[-3]<>0,R[-11]C=1),1,0)"
    Range("D20").FormulaR1C1 = "=IF(OR(RC[-2]=1,R[1]C[-2]=1,R[-11]C=1),1,0)"
    Range("H23").FormulaR1C1 = "=IF(OR(R[-4]C[-6]=1,R[-3]C[-6]=1,R[-2]C[-6]=1,R[11]C=1),1,0)"
    Range("G26").FormulaR1C1 = "=IF(OR(RC[-5]=1,R[-11]C=1),1,0)"
 
    'Formules Rez de chaussée
    Range("C116").FormulaR1C1 = "=RC[-1]"
    Range("F117").FormulaR1C1 = "=IF(OR(RC[-4]<>0,R[-11]C=1),1,0)"
    Range("E118").FormulaR1C1 = "=IF(OR(RC[-3]<>0,R[-11]C=1),1,0)"
    Range("D119").FormulaR1C1 = "=IF(OR(RC[-2]=1,R[1]C[-2]=1,R[-11]C=1),1,0)"
    Range("H122").FormulaR1C1 = "=IF(OR(R[-4]C[-6]=1,R[-3]C[-6]=1,R[-2]C[-6]=1),1,0)" 'J'ai supprimé le R[11]C=1 qui testait une ligne dans les totaux. Mais je n'arrive pas à faire en sorte que la modification soit effective dans la feuille...
    Range("G125").FormulaR1C1 = "=IF(OR(RC[-5]=1,R[-11]C=1),1,0)"
End Sub

Module 3 :

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
79
80
81
82
83
84
85
86
87
88
89
Sub Ajouter_Un_Etage()
    Application.ScreenUpdating = False
    Sheets("Chutes de gaines").Select
    Rows("5:15").Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
 
    'on efface le contenu de la bande verte du nouvel étage
    DerCol = [XFD2].End(xlToLeft).Column 'Nouvelle dernière colonne
    For i = 2 To DerCol
        Range(Cells(5, i), Cells(15, i)).ClearContents 'Ici je n'ai pas fais la modif parce que je ne suis pas sur que cela soit aussi simple pour copier étage courant et non dernier étage --> 16-26 au lieu de 5-15? Mais que se passe-t-il quand il n'y en a pas encore dans la feuille?
    Next i
 
    'Numérotation des étages
    NbEtages = Replace([A12], "R+", "", 1, 2)
    [A12] = "R+" & NbEtages + 1
 
    'recopier les formules du dernier étage sur les autres gaines
    For i = 2 To DerCol Step 7
        Cells(6, i + 1).FormulaR1C1 = "=RC[-1]" 'Dev
        Cells(7, i + 4).FormulaR1C1 = "=IF(RC[-4],1,0)" 'EP
        Cells(8, i + 3).FormulaR1C1 = "=IF(RC[-3],1,0)" 'EV
        Cells(9, i + 2).FormulaR1C1 = "=IF(OR(RC[-2]=1,R[1]C[-2]=1),1,0)" 'EU
        Cells(12, i + 6).FormulaR1C1 = "=IF(OR(R[-4]C[-6]=1,R[-3]C[-6]=1,R[-2]C[-6]=1,R[11]C=1),1,0)" 'VMC
        Cells(15, i + 5).FormulaR1C1 = "=IF(RC[-5]=1,1,0)" 'ECS
    Next i
 
    'recopier les formules des étages intermédiaires sur les autres gaines
    If NbEtages >= 1 Then ' j'ai modifié le nombre d'étage et est-t-il possible de modifier formule VMC du RDC si possible (comme dans le Module 1)?...
        For i = 2 To DerCol Step 7
            Cells(17, i + 1).FormulaR1C1 = "=RC[-1]"
            Cells(18, i + 4).FormulaR1C1 = "=IF(OR(RC[-4]<>0,R[-11]C=1),1,0)"
            Cells(19, i + 3).FormulaR1C1 = "=IF(OR(RC[-3]<>0,R[-11]C=1),1,0)"
            Cells(20, i + 2).FormulaR1C1 = "=IF(OR(RC[-2]=1,R[1]C[-2]=1,R[-11]C=1),1,0)"
            Cells(23, i + 6).FormulaR1C1 = "=IF(OR(R[-4]C[-6]=1,R[-3]C[-6]=1,R[-2]C[-6]=1,R[11]C=1),1,0)" 'à voir pour retirer le R[11]C=1 du RDC
            Cells(26, i + 5).FormulaR1C1 = "=IF(OR(RC[-5]=1,R[-11]C=1),1,0)"
        Next i
    End If
 
    'on applique les MFC
    MFC_Chutes
    Sheets("Construction").Select
    [D3] = NbEtages + 1
End Sub
 
Sub Supprimer_Un_Etage()
    Application.ScreenUpdating = False
    On Error GoTo Erreur
 
    Sheets("Chutes de gaines").Select
    If [A12] = "R+1" Then 'J'ai modifié le niveau pour empêcher la suppression du R+1 sinon les formules du RDC ne fonctionnent plus.
        MsgBox "Vous ne pouvez pas supprimer le R+1"
        Exit Sub
    End If
    Rows("5:15").Select
    Selection.Delete Shift:=xlUp
    NbEtages = Replace([A12], "R+", "", 1, 2)
    DerCol = [XFD2].End(xlToLeft).Column
 
    If NbEtages <> "RDC" Then
        'recopier les formules du dernier étage sur les autres gaines
        For i = 2 To DerCol Step 7
            Cells(6, i + 1).FormulaR1C1 = "=RC[-1]"
            Cells(7, i + 4).FormulaR1C1 = "=IF(RC[-4],1,0)"
            Cells(8, i + 3).FormulaR1C1 = "=IF(RC[-3],1,0)"
            Cells(9, i + 2).FormulaR1C1 = "=IF(OR(RC[-2]=1,R[1]C[-2]=1),1,0)"
            Cells(12, i + 6).FormulaR1C1 = "=IF(OR(R[-4]C[-6]=1,R[-3]C[-6]=1,R[-2]C[-6]=1,R[11]C=1),1,0)"
            Cells(15, i + 5).FormulaR1C1 = "=IF(RC[-5]=1,1,0)"
            Col = Col + 7
        Next i
    End If
 
    'recopier les formules des étages intermédiaires sur les autres gaines
    If NbEtages <> "RDC" And NbEtages >= 1 Then ' J'ai modifié le nombre d'étage 
        For i = 2 To DerCol Step 7
            Cells(17, i + 1).FormulaR1C1 = "=RC[-1]"
            Cells(18, i + 4).FormulaR1C1 = "=IF(OR(RC[-4]<>0,R[-11]C=1),1,0)"
            Cells(19, i + 3).FormulaR1C1 = "=IF(OR(RC[-3]<>0,R[-11]C=1),1,0)"
            Cells(20, i + 2).FormulaR1C1 = "=IF(OR(RC[-2]=1,R[1]C[-2]=1,R[-11]C=1),1,0)"
            Cells(23, i + 6).FormulaR1C1 = "=IF(OR(R[-4]C[-6]=1,R[-3]C[-6]=1,R[-2]C[-6]=1,R[11]C=1),1,0)"
            Cells(26, i + 5).FormulaR1C1 = "=IF(OR(RC[-5]=1,R[-11]C=1),1,0)"
        Next i
    End If
    'on applique les MFC
    MFC_Chutes
    Sheets("Construction").Select
    If NbEtages = "RDC" Then [D3] = "0 étage" Else: [D3] = NbEtages
Erreur:
End Sub

J'ai remis le fichier ce qui vous évite de refaire les modifications.Pièce jointe 432751

Dans tout les cas je vous remercie pour tout ce que vous faites.

Cordialement

Bonjour,

Voilà pour les ajustements, cependant pour la dernière question concernant l'ajout d'un étage, actuellement il recopie le dernier étage, refait les formules pour les adapter à chaque étage, alors pourquoi recopier l'étage courant et non le dernier étage?
Code:

1 2 3 For i = 2 To DerCol Range(Cells(5, i), Cells(15, i)).ClearContents 'Ici je n'ai pas fais la modif parce que je ne suis pas sur que cela soit aussi simple pour copier étage courant et non dernier étage --> 16-26 au lieu de 5-15? Mais que se passe-t-il quand il n'y en a pas encore dans la feuille? Next i
Pour les formules du RDC, c'est fait.

Pour les MFC , je vous ai fait les 3 solutions, j'ai mis celle qui s'arrête au 1er étage, prenez celle qui vous convient.
Code:

1 2 3 4 5 '*********** choisissez à quel niveau doit s'arr$eter la MFC **************** 'Set Rng = Range(Cells(5, Cpt), Cells(DerLig - 9, Cpt)) '****** la plage s'arrête au RDC Set Rng = Range(Cells(5, Cpt), Cells(DerLig - 20, Cpt)) '****** la plage s'arrête au 1er étage 'Set Rng = Range(Cells(5, Cpt), Cells(15, Cpt)) '************** la plage s'arrête au dernier étage '******************************************************
Pièce jointe 432908

Cdlt

1 pièce(s) jointe(s)

Bonjour Arturo,

Merci beaucoup pour votre retour!

Effectivement, pour la copie d'étage je n'avais pas compris l'adaptation des formules en insérant des étages mais en effet dans la feuille cela fonctionne!

Pour la formule du RDC de la VMC, j'ai tout simplement gardé une seule gaine, modifié la formule dans la feuille et pouf ça fonctionne!

Pour ce qui est des MFC j'ai récupérer votre code de la V2 qui fonctionnait comme voulu et je l'ai (très légèrement) adapté pour qu'il fonctionne sur ce tableau de taille variable. Et ça fonctionne et ça fait plaisir de réussir un petit quelque chose :D

Je vous remet le fichier en PJ avec mes modifications (seulement celle des MFC je n'ai pas touché au reste).
Pièce jointe 433346
Il faut que je le test un peu plus pour voir s'il fonctionne comme prévu et que je rajoute les totaux de lignes en bas de page.
Je vois déjà un élément à rajouter mais je vais essayer de le coder...

Cordialement