[XL-2007] Modifier forme dans autre feuille [Résolu]

[roni44]

Bonjour, j'ai créé une macro permettant à partir d'une feuille contenant un tableau de mettre au premier ou dernier plan des formes situées dans un autre document.
J'ai fais une boucle du type :
Pour i allant de 1 à 50
Voir si forme 50=vrai (dans la page 2)
alors mettre forme 50 en arrière plan (dans la page 3)
...

Et je suis obligé de rendre chaque page active 2 puis 3 à chaque selection.
Je voudrais que la page active reste la page 2 tout en changeant les formes de la page 3 (en arrière plan) car le calcul devient long.
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
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
Sub Bouton4_clic()
 
Dim y, z
z = 2
For y = 1 To z
Sheets("Base").Copy After:=Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = "S" & 42 + y
 
 
Sheets("Plan").Select
Dim nom_reseau As String
Dim case_init As Range
Set case_init = ActiveSheet.Range("C42")
Dim i As Integer
Dim j As Integer
 
j = Range("E1").Value - 42
 
 
For i = 0 To 59
 
Sheets("Plan").Select
 
case_init.Offset(j, i).Select
 
 
nom_reseau = case_init.Offset(0, i).Value
 
 
Sheets("S" & 42 + y).Select
 
 
If case_init.Offset(j, i) = 0 Then
 
ActiveSheet.Shapes(nom_reseau).Select
Selection.ShapeRange.ZOrder msoSendToBack
ActiveSheet.Shapes(nom_reseau & "b").Select
Selection.ShapeRange.ZOrder msoSendToBack
ActiveSheet.Shapes(nom_reseau & "c").Select
Selection.ShapeRange.ZOrder msoSendToBack
 
ElseIf case_init.Offset(j, i) = 1 Then
 
 
ActiveSheet.Shapes(nom_reseau).Select
Selection.ShapeRange.ZOrder msoSendToFront
ActiveSheet.Shapes(nom_reseau & "b").Select
Selection.ShapeRange.ZOrder msoSendToFront
ActiveSheet.Shapes(nom_reseau & "c").Select
Selection.ShapeRange.ZOrder msoSendToFront
 
Else
ActiveSheet.Shapes(nom_reseau).Select
Selection.ShapeRange.ZOrder msoSendToFront
ActiveSheet.Shapes(nom_reseau & "b").Select
Selection.ShapeRange.ZOrder msoSendToBack
ActiveSheet.Shapes(nom_reseau & "c").Select
Selection.ShapeRange.ZOrder msoSendToBack
 
End If
 
 
 
Next
 
 
 
Next y
 
End Sub

Dites moi si je peux eviter ce sheets select à chaque fois qui rallonge énormément mon calcul.

Merci d'avance

[mercatog]

Essaies comme ceci

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
Sub Bouton4_clic()
Dim y As Byte, z As Byte, m As Byte, n As Byte
Dim i As Integer, j As Integer
Dim Nom_Reseau As String
Dim Case_Init As Range
 
Application.ScreenUpdating = False
With Worksheets("Plan")
    Set Case_Init = .Range("C42")
    j = .Range("E1").Value - 42
    z = 2
    For y = 1 To z
        DeleteSheet Sheets("S" & 4 + y)
        Worksheets("Base").Copy After:=Sheets(Sheets.Count)
        ActiveSheet.Name = "S" & 42 + y
        For i = 0 To 59
            Nom_Reseau = Case_Init.Offset(0, i).Value
            If Case_Init.Offset(j, i) = 0 Then
                m = msoSendToBack
                n = msoSendToBack
            ElseIf Case_Init.Offset(j, i) = 1 Then
                m = msoBringToFront
                n = msoBringToFront
            Else
                m = msoBringToFront
                n = msoSendToBack
            End If
            With Worksheets("S" & 42 + y)
                .Shapes(Nom_Reseau).ZOrder m
                .Shapes(Nom_Reseau & "b").ZOrder n
                .Shapes(Nom_Reseau & "c").ZOrder n
            End With
        Next i
    Next y
    Set Case_Init = Nothing
End With
End Sub
 
Private Sub DeleteSheet(Ws As Worksheet)
 
Application.DisplayAlerts = False
On Error Resume Next
Ws.Delete
On Error GoTo 0
Application.DisplayAlerts = True
End Sub

[roni44]

Bonjour Mercatog.
Merci mille fois pour cette réponse.
J'ai fais quelques modifs car il y avait 2/3 ptites choses qui n'allaient pas mais ca marche du tonnere. Je mets 3s à générer 10 feuilles contre 1min pour une feuille avant...

Pour info le 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
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
Sub Bouton4_clic()
Dim y As Byte, z As Byte, m As Byte, n As Byte
Dim i As Integer, j As Integer
Dim Nom_Reseau As String
Dim Case_Init As Range
 
Application.ScreenUpdating = False
With Worksheets("Plan")
    Set Case_Init = .Range("C42")
    j = .Range("E1").Value - 43
    z = 10
    For y = 1 To z
 
        Worksheets("Base").Copy After:=Sheets(ThisWorkbook.Sheets.Count)
 
        ActiveSheet.Name = "S" & 42 + y
        For i = 0 To 59
            Nom_Reseau = Case_Init.Offset(0, i).Value
            If Case_Init.Offset(j + y, i) = 0 Then
                m = msoSendToBack
                n = msoSendToBack
            ElseIf Case_Init.Offset(j + y, i) = 1 Then
                m = msoBringToFront
                n = msoBringToFront
            Else
                m = msoBringToFront
                n = msoSendToBack
            End If
            With Worksheets("S" & 42 + y)
                .Shapes(Nom_Reseau).ZOrder m
                .Shapes(Nom_Reseau & "b").ZOrder n
                .Shapes(Nom_Reseau & "c").ZOrder n
            End With
        Next i
    Next y
    Set Case_Init = Nothing
End With
End Sub

A bientôt

J'ai une autre petite question à propose d'une chose qui me parait étrange.
Grâce à ma macro je génère une vingtaine de feuilles nommées 2011-S01...2011-S52,2012-S01...2012-S52...
Dans VBA elles s'appellent Feuil4,Feuil5.... Les 3 premières étant mes feuilles de calcul et autre
Par contre j'ai une macro permettant de supprimer les feuilles et quand je fais :

Code :

1
2
3
For i = 4 To Sheets.Count
Sheets(i).Delete
Next i

Il me supprime les feuilles dans un ordre étrange. Il enlève d'abord toutes les feuilles paires : Feuil4 puis Feuil6, Feuil 8....
Après il me met erreur : L'indice n'appartient pas à la selection".
Savez vous comment résoudre ce problème?

Merci d'avance

[mercatog]

Edit

Code :

1
2
3
4
5
6
7
8
9
10
Sub SupprSheet()
Dim i As Integer
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = Sheets.Count To 4 Step -1
    Sheets(i).Delete
Next i
Application.DisplayAlerts = True
End Sub

[roni44]

Parfait !
Je ne vois pas trop pourquoi ma méthode ne fonctionnait pas mais en tout cas là c'est nickel !!
Merci merci

[mercatog]

Code :

For i =4 to 16

Tu commence par supprimer la 4, la 5 devient la 4 et la 6 devient la 5... la 16 devient la 15
le tour suivant tu supprime la 5 (qui était la 6), celle qui était au départ 7ème devient la 5ème et la 8 devient la 6... etc

il arrive que tu supprime les feuilles d'indice pair et tu trouvera avec des indices inexistants.

PS: j'avais édité mon post! (pour pallier aux éventuels messages lors de la suppression de feuilles)