Archivage moins pénible!

[thomlau]

Bonjour a toutes et à tous.

Voilà, j'ai dans mon application, une macro qui prend pas mal de temps à s'éxécuter. Sa longueur en est surement la cause.
J'ai utilisé la recherche, mais en vain. Pas moyen de trouver une portion de code qui permettrai de réduire cette macro.

La voici...🙄 Je sais elle est barbare.

Sub Enregistre()

' Cette macro permet l'archivage du planning hebdomadaire

Dim sem As Integer
sem = Feuil1.Range("G4").Value

    Application.ScreenUpdating = False
   
    Sheets("PLANNING").Select
    Range("B10:H132").Select  'Selection des cellules du planning
   
    Application.CutCopyMode = False
    
    'Copie de toutes les données
    Selection.Copy
       
    If Feuil1.Range("G4") = 1 Then
    Sheets("archives").Select
    Range("B9").Select
    End If
    
    
    If Feuil1.Range("G4") = 2 Then
    Sheets("archives").Select
    Range("B132").Select
    End If
    
    
    If Feuil1.Range("G4") = 3 Then
    Sheets("archives").Select
    Range("B255").Select
    End If
    
    
    If Feuil1.Range("G4") = 4 Then
    Sheets("archives").Select
    Range("B378").Select
    End If
    
    
    If Feuil1.Range("G4") = 5 Then
    Sheets("archives").Select
    Range("B501").Select
    End If
    
    
    If Feuil1.Range("G4") = 6 Then
    Sheets("archives").Select
    Range("B624").Select
    End If
    
    
    If Feuil1.Range("G4") = 7 Then
    Sheets("archives").Select
    Range("B747").Select
    End If
    
    
    If Feuil1.Range("G4") = 8 Then
    Sheets("archives").Select
    Range("B870").Select
    End If
    
    
    If Feuil1.Range("G4") = 9 Then
    Sheets("archives").Select
    Range("B993").Select
    End If
    
    
    If Feuil1.Range("G4") = 10 Then
    Sheets("archives").Select
    Range("B1116").Select
    End If
    
    
    If Feuil1.Range("G4") = 11 Then
    Sheets("archives").Select
    Range("B1239").Select
    End If
    
    
    If Feuil1.Range("G4") = 12 Then
    Sheets("archives").Select
    Range("B1362").Select
    End If
    
    
    If Feuil1.Range("G4") = 13 Then
    Sheets("archives").Select
    Range("B1485").Select
    End If
    
    
    If Feuil1.Range("G4") = 14 Then
    Sheets("archives").Select
    Range("B1608").Select
    End If
    
    
    If Feuil1.Range("G4") = 15 Then
    Sheets("archives").Select
    Range("B1731").Select
    End If
    
    
    If Feuil1.Range("G4") = 16 Then
    Sheets("archives").Select
    Range("B1854").Select
    End If
    
    
    If Feuil1.Range("G4") = 17 Then
    Sheets("archives").Select
    Range("B1977").Select
    End If
    
    
    If Feuil1.Range("G4") = 18 Then
    Sheets("archives").Select
    Range("B2100").Select
    End If
    
    
    If Feuil1.Range("G4") = 19 Then
    Sheets("archives").Select
    Range("B2223").Select
    End If
    
    
    If Feuil1.Range("G4") = 20 Then
    Sheets("archives").Select
    Range("B2346").Select
    End If
    
    
    If Feuil1.Range("G4") = 21 Then
    Sheets("archives").Select
    Range("B2469").Select
    End If
    
    
    If Feuil1.Range("G4") = 22 Then
    Sheets("archives").Select
    Range("B2592").Select
    End If
    
    
    If Feuil1.Range("G4") = 23 Then
    Sheets("archives").Select
    Range("B2715").Select
    End If
    
    
    If Feuil1.Range("G4") = 24 Then
    Sheets("archives").Select
    Range("B2838").Select
    End If
    
    
    If Feuil1.Range("G4") = 25 Then
    Sheets("archives").Select
    Range("B2961").Select
    End If
    
    
    If Feuil1.Range("G4") = 26 Then
    Sheets("archives").Select
    Range("B3084").Select
    End If
    
    
    If Feuil1.Range("G4") = 27 Then
    Sheets("archives").Select
    Range("B3207").Select
    End If
    
    
    If Feuil1.Range("G4") = 28 Then
    Sheets("archives").Select
    Range("B3330").Select
    End If
    
    
    If Feuil1.Range("G4") = 29 Then
    Sheets("archives").Select
    Range("B3453").Select
    End If
    
    
    If Feuil1.Range("G4") = 30 Then
    Sheets("archives").Select
    Range("B3576").Select
    End If
    
    
    If Feuil1.Range("G4") = 31 Then
    Sheets("archives").Select
    Range("B3699").Select
    End If
    
    
    If Feuil1.Range("G4") = 32 Then
    Sheets("archives").Select
    Range("B3822").Select
    End If
    
    
    If Feuil1.Range("G4") = 33 Then
    Sheets("archives").Select
    Range("B3945").Select
    End If
    
    
    If Feuil1.Range("G4") = 34 Then
    Sheets("archives").Select
    Range("B4068").Select
    End If
    
    
    If Feuil1.Range("G4") = 35 Then
    Sheets("archives").Select
    Range("B4191").Select
    End If
    
    
    If Feuil1.Range("G4") = 36 Then
    Sheets("archives").Select
    Range("B4314").Select
    End If
    
    
    If Feuil1.Range("G4") = 37 Then
    Sheets("archives").Select
    Range("B4437").Select
    End If
    
    
    If Feuil1.Range("G4") = 38 Then
    Sheets("archives").Select
    Range("B4560").Select
    End If
    
    
    If Feuil1.Range("G4") = 39 Then
    Sheets("archives").Select
    Range("B4683").Select
    End If
    
    
    If Feuil1.Range("G4") = 40 Then
    Sheets("archives").Select
    Range("B4806").Select
    End If
    
    
    If Feuil1.Range("G4") = 41 Then
    Sheets("archives").Select
    Range("B4929").Select
    End If
    
    
    If Feuil1.Range("G4") = 42 Then
    Sheets("archives").Select
    Range("B5052").Select
    End If
    
    
    If Feuil1.Range("G4") = 43 Then
    Sheets("archives").Select
    Range("B5175").Select
    End If
    
    
    If Feuil1.Range("G4") = 44 Then
    Sheets("archives").Select
    Range("B5298").Select
    End If
    
    
    If Feuil1.Range("G4") = 45 Then
    Sheets("archives").Select
    Range("B5421").Select
    End If
    
    
    If Feuil1.Range("G4") = 46 Then
    Sheets("archives").Select
    Range("B5544").Select
    End If
    
    
    If Feuil1.Range("G4") = 47 Then
    Sheets("archives").Select
    Range("B5667").Select
    End If
    
    
    If Feuil1.Range("G4") = 48 Then
    Sheets("archives").Select
    Range("B5790").Select
    End If
    
    
    If Feuil1.Range("G4") = 49 Then
    Sheets("archives").Select
    Range("B5913").Select
    End If
    
    
    If Feuil1.Range("G4") = 50 Then
    Sheets("archives").Select
    Range("B6036").Select
    End If
    
    
    If Feuil1.Range("G4") = 51 Then
    Sheets("archives").Select
    Range("B6159").Select
    End If
    
    
    If Feuil1.Range("G4") = 52 Then
    Sheets("archives").Select
    Range("B6282").Select
    End If
    
    
    If Feuil1.Range("G4") = 53 Then
    Sheets("archives").Select
    Range("B6405").Select
    End If
    
    'Copie du planning à l'endroit qui s'y rapporte
    Sheets("archives").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    Sheets("PLANNING").Select
    Range("A1").Select  'Retour vers le planning
    
    Application.ScreenUpdating = True
    MsgBox "Le planning de la semaine " & sem & " a bien été archivé."
        
       
End Sub

Si quelqu'un pouvait m'aider ce serait sympa. Je pourrais enfin comprendre le processus qui m'interesse.

d'avance merci.

 

[Cousinhub]

Re : Archivage moins pénible!

Bonjour, à tester :

Sub Enregistre()
Dim sem As Integer, i, j
Application.ScreenUpdating = True
sem = Feuil1.Range("G4").Value
Range("B10:H132").Copy
For i = 1 To 53
    If i = sem Then
    j = 9 + ((i - 1) * 123)
        Sheets("archives").Select
        Range("B" & j).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
Next i
    Sheets("PLANNING").Select
    Range("A1").Select  'Retour vers le planning 
    Application.ScreenUpdating = True
    MsgBox "Le planning de la semaine " & sem & " a bien été archivé."
End Sub

 

[Staple1600]

Re : Archivage moins pénible!

Bonjour (recollision bhbh 😉 )



En essayant de ce côté edit: voir plutot la piste de bhbh

(je tatonne pour le moment)

sub test()
Dim i As Integer
Dim sem As Integer
' j'ai changer la référence de la feuille pour test
sem = Sheets(1).Range("G4").Value
Application.ScreenUpdating = False
Sheets("PLANNING").Range("B10:H132").Copy
For i = 2 To 53
Select Case Feuil1.Range("G4").Value
Case i
' à adapter à ton cas  .Select
MsgBox Sheets(1).Cells(i + 123, "B").Address(0, 0)
End Select
Next
'et ici le code pour coller ( à tester)

 

[thomlau]

Re : Archivage moins pénible!

Merci bhbh.

Tu m'enlève une sacrée épine du pied. Ca faisait pas mal de temps que je voulais arriver à ce résultat.

Tu avais juste oublié un End If avant Next i, mais ceci dit, ta macro fonctionne admirablement bien.

Encore merci. Bon WE à tous

 

[thomlau]

Re : Archivage moins pénible!

Bonjour et merci Staple de te pencher sur le sujet.

La macro de bhbh est je crois, celle que je vais garder.

++

 

[Staple1600]

Re : Archivage moins pénible!

RE


Je suis entièrement d'accord , pendant que je tatonne ,bhbh gaze lui

Sa solution est limpide

 

[Cousinhub]

Re : Archivage moins pénible!

Re-,

comment ça : gaze ?
et le End If oublié, un peu amateur? 😀
même pas fait une compilation, tout se perd.... 😱

 

[Staple1600]

Re : Archivage moins pénible!

Re

Je parle de ta rapidité à lire un code vba
à le transformer ( avec indentation du code)

le tout en 12 minutes!

J'appelle ca gazer, ou si tu préféres avoir une vélocité neuronnale
hors du commun.

Je suis admiratif.

 

[Victor21]

Re : Archivage moins pénible!

Bonjour Thomlau.

en H4 : =SOMME((G4-1)*123)+9

et remplace tous tes If(G4) par cette ligne unique

Application.Goto Range("B" & [H4].Value)

Cela te convient-il ?

 

[Cousinhub]

Re : Archivage moins pénible!

Re-,
effectivement, victor à raison : sans boucle

Sub Enregistre()
Dim sem As Integer,
Application.ScreenUpdating = True
sem = 9 + ((Feuil1.Range("G4").Value - 1) * 123)
Range("B10:H132").Copy
        Sheets("archives").Select
        Range("B" & sem).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    Sheets("PLANNING").Select
    Range("A1").Select  'Retour vers le planning
    Application.ScreenUpdating = True
    sem = Feuil1.Range("G4").Value
    MsgBox "Le planning de la semaine " & sem & " a bien été archivé."
End Sub