Modifier forme dans autre feuille

Version imprimable

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

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

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

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

08/11/2011, 09h48
roni44

Parfait !
Je ne vois pas trop pourquoi ma méthode ne fonctionnait pas mais en tout cas là c'est nickel !!
Merci merci
08/11/2011, 09h56
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)