Reorganisation macro

tactic6 · 1 Novembre 2009

Bonjour le forum

à l'aide de l'enregistreur de macro j'ai réalisé un bout de code qui va tres bien
je voudrais juste savoir si il etait possible de le rendre plus simple et plus clair
En vous remerciant par avance je vous souhaite à tous un tres bon dimanche

le code:

Code:

Sub Macro3()
'
' Macro3 Macro
'

Application.ScreenUpdating = False

    Sheets("SAISIE").Select
    Sheets("SAISIE").Unprotect
    Range("G6").Value = "FACTURE N°"
    Sheets("Feuil2").Select
    Range("I5:J5").Select
    Selection.Copy
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    Sheets("SAISIE").Select
    Sheets("SAISIE").Unprotect
    Range("I5").Select
    ActiveWindow.ScrollWorkbookTabs Position:=xlLast
    Sheets("Feuil2").Select
    Selection.Copy
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    Sheets("SAISIE").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    ActiveWindow.ScrollWorkbookTabs Position:=xlLast
    Sheets("Feuil2").Select
    Range("J6").Select
    Selection.Copy
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    Sheets("SAISIE").Select
    Range("J6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveWindow.ScrollWorkbookTabs Position:=xlLast
    Sheets("Feuil2").Select
    Range("C12:D12").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    Sheets("SAISIE").Select
    Range("C12:D12").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveWindow.ScrollWorkbookTabs Position:=xlLast
    Sheets("Feuil2").Select
    Range("B15:I52").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    Sheets("SAISIE").Select
    Range("B15:I52").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveWindow.ScrollWorkbookTabs Position:=xlLast
    Sheets("Feuil2").Select
    Range("K15:K52").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    Sheets("SAISIE").Select
    ActiveWindow.SmallScroll Down:=-3
    Range("K15:K52").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("SAISIE").Protect
    Range("C12").Select
    Sheets("Feuil2").Select
    Range("I5:J5").Select
    Selection.ClearContents
    Range("J6").Select
    Selection.ClearContents
    Range("G8:K8").Select
    Selection.ClearContents
    Range("H9:J9").Select
    Selection.ClearContents
    Range("C12:D12").Select
    Selection.ClearContents
    Range("H12:J12").Select
    Selection.ClearContents
    Range("B15:B52").Select
    Selection.ClearContents
    Range("C15:C52").Select
    Selection.ClearContents
    Range("H15:H52").Select
    Selection.ClearContents
    Range("I15:I52").Select
    Selection.ClearContents
    Range("J15:J52").Select
    Selection.ClearContents
    Range("K15:K52").Select
    Selection.ClearContents
    Range("B55:B59").Select
    Selection.ClearContents
    Range("C55:C59").Select
    Selection.ClearContents
    Range("D55:D59").Select
    Selection.ClearContents
    Range("J54:J59").Select
    Selection.ClearContents
    Sheets("SAISIE").Select


End Sub

Un Code précédent me remplit la Feuil2
Ce code prend des informations d'une Feuil2 pour les transcrire dans la feuille "SAISIE" puis la Feuil2 redevient vierge

Robert · 1 Novembre 2009

Re : Reorganisation macro

Bonjour Tactic, bonjour le forum,

En espérant ne pas m'être trompé, voici ton code simplifié. Comme tu le remarqueras, il faut supprimer autant que possible tous les Select qui ralentissent considérablement le code. Par exemple,
Range("A1").Select
Selection.ClearContents
est à bannir ! Car Range("A1").Clearcontents suffit...

Code:

Sub Macro3()
Application.ScreenUpdating = False
 
With Sheets("SAISIE")
    .Activate
    .Unprotect
    .Range("G6").Value = "FACTURE N°"
    Sheets("Feuil2").Range("I5:J5").Copy
    .Range("I5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Feuil2").Range("J6").Copy
    .Range("J6").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Feuil2").Range("C12:D12").Copy
    .Range("C12:D12").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Feuil2").Range("B15:I52").Copy
    .Range("B15:I52").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Feuil2").Range("K15:K52").Copy
    .Range("K15:K52").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    .Protect
    .Range("C12").Select
End With
 
With Sheets("Feuil2")
    .Range("I5:J6").ClearContents
    .Range("G8:K8").ClearContents
    .Range("H9:J9").ClearContents
    .Range("C12:D12").ClearContents
    .Range("H12:J12").ClearContents
    .Range("B15:C52").ClearContents
    .Range("H15:K52").ClearContents
    .Range("B55:D59").ClearContents
    .Range("J54:J59").ClearContents
End With
 
Application.ScreenUpdating = True
End Sub

L'utilisation de With, End With évite les répétitions de code. Le point . dans le code indique que ce qui suit se réfère au With.

tactic6 · 1 Novembre 2009

Re : Reorganisation macro

Merci Robert
en plus de me simplifier le code tu me donnes de tres bonnes explications
peut être évidentes pour les exceliens mais si compliquées pour nous

Bon Dimanche

ROGER2327 · 1 Novembre 2009

Re : Reorganisation macro

Bonjour à vous

Je suis en retard, mais puisque je l'ai fait (et que c'est plus court), je livre.

Code:

[COLOR="DarkSlateGray"]Sub Macro3()
   Application.ScreenUpdating = False
   With Sheets("SAISIE")
      .Select
      .Unprotect
      .Range("G6").Value = "FACTURE N°"
      Sheets("Feuil2").Range("I5:J5").Copy
      .Range("I5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
         :=False, Transpose:=False
      Sheets("Feuil2").Range("J6").Copy
      .Range("J6").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
         :=False, Transpose:=False
      Sheets("Feuil2").Range("C12:D12").Copy
      .Range("C12:D12").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
         :=False, Transpose:=False '34
      Sheets("Feuil2").Range("B15:I52").Copy
      .Range("B15:I52").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
         :=False, Transpose:=False
      Sheets("Feuil2").Range("K15:K52").Copy
      .Range("K15:K52").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
         :=False, Transpose:=False
      Application.CutCopyMode = False
      Sheets("Feuil2") _
         .Range("B15:C52,B55:D59,C12:D12,I5:J5,J6,G8:K8,H9:J9,H12:J12,H15:K52,J54:J59").ClearContents
      .Range("C12").Select
      .Protect
   End With
End Sub[/COLOR]

A vérifier, car en l'absence d'un classeur support, difficile de tester...

ROGER2327
#2018

tactic6 · 1 Novembre 2009

Re : Reorganisation macro

Merci c'est cool

Staple1600 · 1 Novembre 2009

Re : Reorganisation macro

Bonjour à tous

S'il s'agit de faire court 😉

Voici encore plus court

Code:

Sub Macro33()
Dim t, i As Long
t = Split("I5:J5+J6+C12:D12+B15:I52+K15:K52", "+")
Application.ScreenUpdating = False
   With Sheets("SAISIE")
      .Select
      .Unprotect
      .Range("G6").Value = "FACTURE N°"
            For i = LBound(t) To UBound(t)
            .Range(CStr(t(i))).Value = Sheets("Feuil2").Range(CStr(t(i))).Value
            Next
      .Protect
   End With
Sheets("Feuil2").Range("B15:C52,B55:D59,C12:D12,I5:J5,J6,G8:K8,H9:J9,H12:J12,H15:K52,J54:J59").ClearContents
End Sub

ROGER2327 · 1 Novembre 2009

Re : Reorganisation macro

Bonjour Staple1600

Bien vu !

ROGER2327
#2020

Staple1600 · 1 Novembre 2009

Re : Reorganisation macro

Bonjour ROGER2327

J'ai laissé le Select mais on peut l' ôter aussi (ligne 5)

tactic6 · 1 Novembre 2009

Re : Reorganisation macro

Bonsoir,
Vous êtes impressionnants

Merci

ROGER2327 · 1 Novembre 2009

Re : Reorganisation macro

Re... (à Staple1600)

Juste pour chercher la petite bête : Dans la procédure initiale, la sélection finale était Sheets("SAISIE").Range("C12").Select d'où la nécessité de garder cette ligne si la feuille "SAISIE" n'est pas la feuille active au moment de l'appel de la procédure. Mais, vu le nombre de lignes inutiles dans la procédure initiale, peut-être aussi que cette sélection n'a pas d'importance pour notre ami... A lui de voir...

ROGER2327
#2021

tactic6 · 1 Novembre 2009

Re : Reorganisation macro

Re
Moi aussi j'ai été étonné de ne pas trouver le C12.select mais mine de rien après l'exécution de la macro C12 est bien sélectionné
ma foi je ne sais pas pourquoi mais bon ça marche et je le confirme vous etes vraiment impressionnants
J'ai encore un code qui fait une tartine
si je vous le poste vous pourriez me l'alléger ? ( mais avec quelques explications si possible )

Staple1600 · 1 Novembre 2009

Re : Reorganisation macro

Re

Envoie plutôt le classeur (zippé) que l'on puisse tester avant d'alléger

PS: Pourquoi avais tu besoin de sélectionner C12 ?

tactic6 · 1 Novembre 2009

Re : Reorganisation macro

Re
Le C12 correspond a la case code client c'est uniquement pour se mettre sur la page pas d'importance primordiale
pour le zip ça va être dur car mon classeur pèse zippé 5 Mo et si je le réduit ça ne fonctionne plus

je tente le code
comme il est ça marche mais j'aime voir plusieurs versions et c'est tellement plus agréable quand c'est court

Code:

Sub Enregistrer_Facture(ByVal control As IRibbonControl)
Application.ScreenUpdating = False
Worksheets("SAISIE").Select
Worksheets("SAISIE").Unprotect

Dim Table() As String
Dim tablo(1, 6)
Dim tabloErreur As Variant
Dim tabloMsg As Variant
Dim tabloFacture As Variant
Dim msg As String
Dim msg1 As String
Dim msg2 As String
Dim f1  As Worksheet
Dim f2 As Worksheet
Dim Derli As Long
Dim i As Integer
If ActiveSheet.Range("g6").Value = "DEVIS N°" Then
    MsgBox " cette feuille est un devis, vous ne pouvez l'enregistrer"
    Else
 'initialisation des variables
Set f1 = Sheets("SAISIE")
Set f2 = Sheets("Recap_Facture")
 ' affectaction des valeurs de cellules au tableau
tablo(1, 1) = f1.[C12]
tablo(1, 2) = f1.[I5]
tablo(1, 3) = f1.[J6]
tablo(1, 4) = f1.[G8]
tablo(1, 5) = f1.[H12]
tablo(1, 6) = f1.[J59]
'Gestion des cellules non renseignées
tabloErreur = Array("", "Date", "")
tabloMsg = Array("nom", "date", "numéro")
msg1 = "Il n'y a pas de "
msg2 = ", la facture ne peut pas être enregistrée."
'boucle pour l'affichage des cellules non remplies
For i = 3 To 1 Step -1
   If tablo(1, i) = tabloErreur(i) Then msg = msg & vbLf & msg1 & tabloMsg(i) & msg2
Next i
'si une condition remplie, affichage du message d'erreur et fin de Sub
If Not msg = "" Then MsgBox msg: Exit Sub
' controle ligne TVA
For i = 15 To 52
  If f1.Cells(i, "J").Value <> "" And _
      f1.Cells(i, "K").Value = "" Then _
         MsgBox "la cellule " & Cells(i, "K").Address & " est vide.": End
Next i
'Recherche  de la dernière ligne de l'onglet "Recap_Facture"
Derli = f2.Columns("A").Find("*", , , , , xlPrevious).Row ' + 1

'Gestion des doublons
tabloFacture = f2.Range("C1:C" & Derli).Value
'si doublon, affichage du message et fin de Sub
If Not IsError(Application.Match(tablo(1, 3), tabloFacture, 0)) Then _
   MsgBox "Le numéro de la facture """ & tablo(1, 3) & """ existe déja!": Exit Sub

'insertion des données sur Recap_Facture
Derli = Derli + 1
f2.Cells(Derli, "I").Value = Now
f2.Range("A" & Derli & ":F" & Derli).Value = tablo



Const DossierSauvegarde As String = "F:\Sauvegarde_2009\Recap_Facture\" ' à modifier selon l'emplacement de ton dossier
Const DossierSauvegarde2 As String = "F:\Sauvegarde_2009\Facture\"
Const DossierSauvegarde3 As String = "j:\Sauvegarde_2009\Facture\"
Const DossierSauvegarde4 As String = "j:\Sauvegarde_2009\Recap_Facture\"
Const DossierSauvegarde5 As String = "j:\Sauvegarde_2009\Archives\"
Dim AWbk As Workbook
Dim LaFin As String
Dim Ext As String
Dim NomClasseur As String
Dim Nom_fichier As String
Dim Nume As String
Set AWbk = ActiveWorkbook
For Each Obj In ActiveSheet.OLEObjects
If TypeOf Obj.Object Is MSForms.CommandButton Then Obj.Delete
Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Sheets("Recap_Facture").Copy
nomfichier = "Recap_Facture"

ActiveWorkbook.SaveAs DossierSauvegarde & nomfichier & " ", FileFormat:=-4143, CreateBackup:=False
ActiveWorkbook.SaveAs DossierSauvegarde4 & nomfichier & " ", FileFormat:=-4143, CreateBackup:=False

ActiveWorkbook.Close



Sheets("SAISIE").Unprotect
Sheets("Modele").Visible = True
Sheets("Modele").Unprotect
    Sheets("SAISIE").Select
    Range("B15:K59").Copy
    Sheets("Modele").Select
    Range("B15:K59").Select
    Sheets("Modele").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    ActiveWindow.SmallScroll Down:=0
    Sheets("SAISIE").Select
    Range("C12").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Modele").Select
    Range("C12").Select
    Sheets("Modele").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Sheets("SAISIE").Select
      Range("I5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Modele").Select
    Range("I5").Select
    Sheets("Modele").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
     Sheets("SAISIE").Select
    Range("G6").Copy
    Sheets("Modele").Select
    Range("G6").Select
    Sheets("Modele").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    ActiveWindow.SmallScroll Down:=0
    Sheets("SAISIE").Select
    Range("J6").Copy
    Sheets("Modele").Select
    Range("J6").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    ActiveWindow.SmallScroll Down:=0
    Sheets("SAISIE").Select
    Range("G8").Copy
    Sheets("Modele").Select
    Range("G8").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    ActiveWindow.SmallScroll Down:=0
    Sheets("SAISIE").Select
    Range("H9").Copy
    Sheets("Modele").Select
    Range("H9").Select
    ActiveWindow.SmallScroll Down:=0
    Sheets("SAISIE").Select
    Range("G10").Copy
    Sheets("Modele").Select
    Range("G10").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    ActiveWindow.SmallScroll Down:=0
    Sheets("SAISIE").Select
    Range("H12").Copy
    Sheets("Modele").Select
    Range("H12").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    ActiveWindow.SmallScroll Down:=0
    Sheets("Modele").Copy
    Nom_fichier = "N°" & " " & Sheets("Modele").Range("J6") & " " & Sheets("Modele").Range("g8") & Format(Now(), "-mmmm" & "-yyyy")
    ActiveWorkbook.SaveAs DossierSauvegarde2 & Nom_fichier & " "
        ActiveWorkbook.SaveAs DossierSauvegarde3 & Nom_fichier & " "
        Application.CutCopyMode = False
ActiveWorkbook.Close
Sheets("Modele").Visible = False
Sheets("Model").Visible = False
Sheets("SAISIE").Select
    Range("C12").Select
Sheets("SAISIE").Protect
Application.ScreenUpdating = True
Mareponse = MsgBox("Voulez vous Imprimer cette FACTURE", vbYesNo, "Impression")
If Mareponse = vbYes Then
ActiveSheet.PageSetup.PrintArea = "$B$2:$K$65"

    ActiveSheet.PrintPreview
    
Else
If Mareponse = vbNo Then
Sheets("Recap_Facture").Select
Derli = f2.Columns("A").Find("*", , , , , xlPrevious).Row
Range("J" & Derli).Value = "non"
End If
End If

End If
Call Transfert
Sheets("ShArchive").Copy
zfichier = "Archive" & Format(Now(), "-dd" & "-mmmm" & "-yyyy")
ActiveWorkbook.SaveAs DossierSauvegarde5 & zfichier & " ", FileFormat:=-4143, CreateBackup:=False
Application.CutCopyMode = False
ActiveWorkbook.Close
Sheets("ShArchive").Visible = False
End Sub

comme je l'ai dit il fonctionne bien
c'est purement par curiosité

Merci

Déjà à quoi servent les ActiveWindow.SmallScroll Down:=0

Staple1600 · 1 Novembre 2009

Re : Reorganisation macro

Re

Tu aurais au moins pu mettre une des versions allégées que l'on vient de te proposer dans ce fil non ??? 😡

tactic6 · 1 Novembre 2009

Re : Reorganisation macro

Re
Les versions allégées sont déjà intégrées dans mon classeur
ce code est complètement différent
ne te fâche pas je voulais juste savoir si des trucs qui vous sautent aux yeux à vous que moi "bleu" de chez stoumph je ne voies pas c'est tout

PS j'ai déjà remplacer les
Range("A1").Select
Selection.ClearContents
par les
Range("A1").Clearcontents
comme Robert me l'a conseillé

Effectuez une recherche sur Excel Downloads...

Reorganisation macro

tactic6

XLDnaute Impliqué

Robert

XLDnaute Barbatruc

tactic6

XLDnaute Impliqué

ROGER2327

XLDnaute Barbatruc

tactic6

XLDnaute Impliqué

Staple1600

XLDnaute Barbatruc

ROGER2327

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

tactic6

XLDnaute Impliqué

ROGER2327

XLDnaute Barbatruc

tactic6

XLDnaute Impliqué

Staple1600

XLDnaute Barbatruc

tactic6

XLDnaute Impliqué

Staple1600

XLDnaute Barbatruc

tactic6

XLDnaute Impliqué

Discussions similaires

Nous accordons de l'importance à votre vie privée