Archivage moins pénible!

thomlau · 2 Février 2008

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.

Code:

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 · 2 Février 2008

Re : Archivage moins pénible!

Bonjour, à tester :

Code:

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 · 2 Février 2008

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)

Code:

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 · 2 Février 2008

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 · 2 Février 2008

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 · 2 Février 2008

Re : Archivage moins pénible!

RE

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

Sa solution est limpide

Cousinhub · 2 Février 2008

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 · 2 Février 2008

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 · 2 Février 2008

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 · 2 Février 2008

Re : Archivage moins pénible!

Re-,
effectivement, victor à raison : sans boucle

Code:

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

Archivage moins pénible!

thomlau

XLDnaute Occasionnel

Cousinhub

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

thomlau

XLDnaute Occasionnel

thomlau

XLDnaute Occasionnel

Staple1600

XLDnaute Barbatruc

Cousinhub

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

Victor21

XLDnaute Barbatruc

Cousinhub

XLDnaute Barbatruc

Discussions similaires

Archivage moins pénible!

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency