Aide pour réduction de code

Version imprimable

Bonjour forum

est ce que possible de réduire se code :
Merci

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
 
Private Sub CommandButton2_Click()
 Dim sh
    Application.ScreenUpdating = 0
    For Each sh In Array("SEPTEMBRE", "OCTOBRE", "NOVEMBRE", "DECEMBRE", "JANVIER", "FEVRIER", "MARS", "AVRIL", "MAI", "JUIN", "JUILLET", "AOUT")
 
        Sheets("ASSURANCE").Range("B3:C32").Copy Sheets(sh).Range("B3")
        Sheets("ASSURANCE").Range("B36:C65").Copy Sheets(sh).Range("B36")
        Sheets("ASSURANCE").Range("B69:C98").Copy Sheets(sh).Range("B69")
        Sheets("ASSURANCE").Range("B102:C131").Copy Sheets(sh).Range("B102")
        Sheets("ASSURANCE").Range("B135:C164").Copy Sheets(sh).Range("B135")
        Sheets("ASSURANCE").Range("B168:C197").Copy Sheets(sh).Range("B168")
        Sheets("ASSURANCE").Range("B201:C230").Copy Sheets(sh).Range("B201")
        Sheets("ASSURANCE").Range("B234:C263").Copy Sheets(sh).Range("B234")
        Sheets("ASSURANCE").Range("B267:C296").Copy Sheets(sh).Range("B267")
        Sheets("ASSURANCE").Range("B300:C329").Copy Sheets(sh).Range("B300")
 
        Sheets("ASSURANCE").Range("B333:C362").Copy Sheets(sh).Range("B333")
        Sheets("ASSURANCE").Range("B366:C395").Copy Sheets(sh).Range("B366")
        Sheets("ASSURANCE").Range("B399:C428").Copy Sheets(sh).Range("B399")
        Sheets("ASSURANCE").Range("B432:C461").Copy Sheets(sh).Range("B432")
        Sheets("ASSURANCE").Range("B465:C494").Copy Sheets(sh).Range("B465")
        Sheets("ASSURANCE").Range("B498:C527").Copy Sheets(sh).Range("B498")
        Sheets("ASSURANCE").Range("B531:C560").Copy Sheets(sh).Range("B531")
        Sheets("ASSURANCE").Range("B564:C593").Copy Sheets(sh).Range("B564")
        Sheets("ASSURANCE").Range("B597:C626").Copy Sheets(sh).Range("B597")
        Sheets("ASSURANCE").Range("B630:C659").Copy Sheets(sh).Range("B630")
 
        Sheets("ASSURANCE").Range("B663:C692").Copy Sheets(sh).Range("B663")
        Sheets("ASSURANCE").Range("B696:C725").Copy Sheets(sh).Range("B696")
        Sheets("ASSURANCE").Range("B729:C758").Copy Sheets(sh).Range("B729")
        Sheets("ASSURANCE").Range("B762:C791").Copy Sheets(sh).Range("B762")
        Sheets("ASSURANCE").Range("B795:C824").Copy Sheets(sh).Range("B795")
        Sheets("ASSURANCE").Range("B828:C857").Copy Sheets(sh).Range("B828")
        Sheets("ASSURANCE").Range("B861:C890").Copy Sheets(sh).Range("B861")
        Sheets("ASSURANCE").Range("B894:C923").Copy Sheets(sh).Range("B894")
        Sheets("ASSURANCE").Range("B927:C956").Copy Sheets(sh).Range("B927")
        Sheets("ASSURANCE").Range("B960:C989").Copy Sheets(sh).Range("B960")
 
        Sheets("ASSURANCE").Range("B993:C1022").Copy Sheets(sh).Range("B993")
        Sheets("ASSURANCE").Range("B1026:C1055").Copy Sheets(sh).Range("B1026")
        Sheets("ASSURANCE").Range("B1059:C1088").Copy Sheets(sh).Range("B1059")
        Sheets("ASSURANCE").Range("B1092:C1121").Copy Sheets(sh).Range("B1092")
        Sheets("ASSURANCE").Range("B1125:C1154").Copy Sheets(sh).Range("B1125")
        Sheets("ASSURANCE").Range("B1158:C1187").Copy Sheets(sh).Range("B1158")
        Sheets("ASSURANCE").Range("B1191:C1220").Copy Sheets(sh).Range("B1191")
        Sheets("ASSURANCE").Range("B1224:C1253").Copy Sheets(sh).Range("B1224")
        Sheets("ASSURANCE").Range("B1257:C1286").Copy Sheets(sh).Range("B1257")
        Sheets("ASSURANCE").Range("B1290:C1319").Copy Sheets(sh).Range("B1290")
 
 
        Sheets("ASSURANCE").Range("B1323:C1352").Copy Sheets(sh).Range("B1323")
        Sheets("ASSURANCE").Range("B1356:C1385").Copy Sheets(sh).Range("B1356")
        Sheets("ASSURANCE").Range("B1389:C1418").Copy Sheets(sh).Range("B1389")
        Sheets("ASSURANCE").Range("B1422:C1451").Copy Sheets(sh).Range("B1422")
        Sheets("ASSURANCE").Range("B1455:C1484").Copy Sheets(sh).Range("B1455")
        Sheets("ASSURANCE").Range("B1488:C1517").Copy Sheets(sh).Range("B1488")
        Sheets("ASSURANCE").Range("B1521:C1550").Copy Sheets(sh).Range("B1521")
        Sheets("ASSURANCE").Range("B1554:C1583").Copy Sheets(sh).Range("B1554")
        Sheets("ASSURANCE").Range("B1587:C1616").Copy Sheets(sh).Range("B1587")
        Sheets("ASSURANCE").Range("B1620:C1649").Copy Sheets(sh).Range("B1620")
 
    Next sh
    MsgBox "Enregistré avec succès" & vbCrLf & "Cliquez sur OK pour fermer", Title:="Info"     
        ActiveWorkbook.Save
End Sub

Code:

1
2
3
4
5
6
7
8
9
10
11
Private Sub CommandButton2_Click()
 Dim sh As String, i As Long
    Application.ScreenUpdating = 0
    For Each sh In Array("SEPTEMBRE", "OCTOBRE", "NOVEMBRE", "DECEMBRE", "JANVIER", "FEVRIER", "MARS", "AVRIL", "MAI", "JUIN", "JUILLET", "AOUT")
        For i = 3 To 1620 Step 33
            Sheets("ASSURANCE").Range("B" & i & ":C" & (i + 29)).Copy Sheets(sh).Range("B" & i)
        Next i
    Next sh
    MsgBox "Enregistré avec succès" & vbCrLf & "Cliquez sur OK pour fermer", Title:="Info"     
    ActiveWorkbook.Save
End Sub

Avoir utilisé des numéros pour tes noms d'onglets (01, 02, 03, etc.) t'aurait évité ce long Array et sans doute facilité les traitements futurs.

1 pièce(s) jointe(s)

Citation:

Envoyé par Menhir

Code:

1
2
3
4
5
Private Sub CommandButton2_Click()
 Dim sh As String, i As Long
    Application.ScreenUpdating = 0
    For Each sh In Array("SEPTEMBRE", "OCTOBRE", "NOVEMBRE", "DECEMBRE", "JANVIER", "FEVRIER", "MARS", "AVRIL", "MAI", "JUIN", "JUILLET", "AOUT")
End Sub

Rebonjour
merci infiniment Menhir
j'ai cette erreurs
Pièce jointe 516092

08/11/2019, 18h30
eriiic

Bonjour à tous,

remet ton

Code:

Dim sh

tout court, qu'il soit Variant.
eric
08/11/2019, 21h31
dreamsodfa

1 pièce(s) jointe(s)

Citation:

Envoyé par Menhir

[CODE]Private Sub CommandButton2_Click()
remet ton

Code:

Dim sh

tout court, qu'il soit Variant.
eric

Bonjour à tous,
Mémé si je mais next sur ce code
j'ai cette erreur
Pièce jointe 516122
Merci
09/11/2019, 01h17
eriiic

Oui, on ne peut qu'être d'accord avec lui.
Pas toi ?
09/11/2019, 01h26
dreamsodfa

Citation:

Envoyé par eriiic

Oui, on ne peut qu'être d'accord avec lui.
Pas toi ?

re;
j'ai pas compris :oops:

Bonjour,

Pour peut-être clore ce dialogue de sourds, le code corrigé

Code:

1
2
3
4
5
6
7
8
9
10
11
Private Sub CommandButton2_Click()
 Dim sh As Variant, i As Long
    Application.ScreenUpdating = 0
    For Each sh In Array("SEPTEMBRE", "OCTOBRE", "NOVEMBRE", "DECEMBRE", "JANVIER", "FEVRIER", "MARS", "AVRIL", "MAI", "JUIN", "JUILLET", "AOUT")
        For i = 3 To 1620 Step 33
            Sheets("ASSURANCE").Range("B" & i & ":C" & (i + 29)).Copy Sheets(sh).Range("B" & i)
        Next i
    Next sh
    MsgBox "Enregistré avec succès" & vbCrLf & "Cliquez sur OK pour fermer", Title:="Info"     
    ActiveWorkbook.Save
End Sub

09/11/2019, 09h13
Philippe Tulliez

Bonjour,

Citation:

j'ai pas compris

Cela signifie qu'il n'y a pas de Next et également qu'il n'y a pas de End If et donc à force de ne pas fermer convenablement les boucles ou les structures conditionnelles, un message non explicite est possible

1 pièce(s) jointe(s)

Citation:

Envoyé par Menhir

Bonjour,

Citation:

Envoyé par eriiic

Bonjour à tous,]

Citation:

Envoyé par Philippe Tulliez

Bonjour,

bonjour forum

Code:

1
2
3
4
5
6
7
8
9
10
11
12
 
Private Sub CommandButton1_Click()
Dim Nom$
 If RNHB.ListIndex = -1 Then MsgBox "Vous devez Sélectionner un mois avant de pouvoir transférer!!", , "Manque de choix": Exit Sub
    Application.ScreenUpdating = 0
 
            For i = 3 To 1620 Step 33
            Sheets("ASSURANCE").Range("B" & i & ":C" & (i + 29)).Copy Sheets(C1.Value).Range("B" & i)
 
    MsgBox "Enregistré avec succès" & vbCrLf & "Cliquez sur OK pour fermer", Title:="Info"
        ActiveWorkbook.Save
End Sub

Se code et lier avec cette combobox

Code:

1
2
3
4
5
6
7
8
 
Private Sub Workbook_Open()
    Dim sh
    Feuil19.RNHB.Clear
    For Each sh In Array("ASSURANCE", "SEPTEMBRE", "OCTOBRE", "NOVEMBRE", "DECEMBRE", "JANVIER", "FEVRIER", "MARS", "AVRIL", "MAI", "JUIN", "JUILLET", "AOUT")
        Feuil19.RNHB.AddItem sh
    Next sh	
End Sub

a la fin du macro je trouve devant moi cette erreur
Pièce jointe 516211

Bonjour,

Ou encore avec l'objet Worksheet ce qui à mon sens est bien plus propre et sans équivoque :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
 
Private Sub CommandButton2_Click()
 
    Dim sh As Worksheet
    Dim i As Long
 
    Application.ScreenUpdating = 0
 
    For Each sh In Worksheets(Array("SEPTEMBRE", "OCTOBRE", "NOVEMBRE", "DECEMBRE", "JANVIER", "FEVRIER", "MARS", "AVRIL", "MAI", "JUIN", "JUILLET", "AOUT"))
 
        For i = 3 To 1620 Step 33
            Sheets("ASSURANCE").Range("B" & i & ":C" & (i + 29)).Copy sh.Range("B" & i)
        Next i
 
    Next sh
 
    MsgBox "Enregistré avec succès" & vbCrLf & "Cliquez sur OK pour fermer", Title:="Info"
 
    ActiveWorkbook.Save
 
End Sub

Code:

1
2
3
4
5
6
7
8
9
10
11
12
 
Private Sub Workbook_Open()
 
    Dim sh As Worksheet
 
    Feuil19.RNHB.Clear
 
    For Each sh In Worksheets(Array("ASSURANCE", "SEPTEMBRE", "OCTOBRE", "NOVEMBRE", "DECEMBRE", "JANVIER", "FEVRIER", "MARS", "AVRIL", "MAI", "JUIN", "JUILLET", "AOUT"))
        Feuil19.RNHB.AddItem sh.Name
    Next sh
 
End Sub

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
 
Private Sub CommandButton1_Click()
 
    Dim Nom$
    Dim I As Integer
 
    If RNHB.ListIndex = -1 Then MsgBox "Vous devez Sélectionner un mois avant de pouvoir transférer!!", , "Manque de choix": Exit Sub
    Application.ScreenUpdating = 0
 
    For I = 3 To 1620 Step 33
        Sheets("ASSURANCE").Range("B" & I & ":C" & (I + 29)).Copy Sheets(RNHB.List(RNHB.ListIndex)).Range("B" & I)
    Next I
 
    MsgBox "Enregistré avec succès" & vbCrLf & "Cliquez sur OK pour fermer", Title:="Info"
 
    ActiveWorkbook.Save
 
End Sub

09/11/2019, 17h51
dreamsodfa

Citation:

Envoyé par Theze

Bonjour,

Re Forum
Merci infiniment tous marcher très bien.
J'ai un petit problème avec le code ça marche trop long ,il dépasser 3 minute pour transférer les donnée.:calim2:
Est il possible de régler ce problème.