Code VBA - Possibilité d'accélérer un code assez long ?

Yvouille · 19 Juin 2008

Bonsoir,

Je cherche un moyen d'accélérer quelque peu la succession des codes ci-dessous qui dure environ 20 secondes au total.

Pensez-vous qu'il y a une solution ?

Code:

Option Explicit
Public v_BaseMoisPrécédent As String ' Utilisé dans Sub Recherche_FichierMoisPrécédent_Copier_feuille_Refermer_FichierMoisPrécédent()
Public Date_décompte As Date, chemin As String, vmois As String, annee As String, vmois1 As String
Public message As String, title As String, default As String

Sub Macro_de_macros()
    
    
    Application.Run _
        "Importer_RepListeQuellensteuer"
        
    Application.Run _
        "Recherche_FichierMoisPrécédent_CopierFeuille_RefermerFichierMoisPrécédent"
            
    Application.Run "BordsGris_Cadres"
    
    Application.Run "Assurés_disparus_depuis_mois_précédent"
    
    Application.Run "Controle_montant_impôt"
    
    Application.Run "Mise_en_place_bouton"
    
    
End Sub

Sub Importer_RepListeQuellensteuer()
       
       Application.ScreenUpdating = False
        

Workbooks.Open Filename:="U:\aaa_RepListeQuellensteuer_BASE.xls"
        
       
        Sheets("RepListeQuellensteuer").Move Before:=Workbooks("aaa_QUELLENSTEUER.xls").Sheets(1)
        Range("A:A,B:B,F:F").Delete Shift:=xlToLeft
        Range("I1") = "LEISTUNGS- ENDE"
        Range("J1") = "BEMERKUNG"
        Range("G1") = "BRUTTO- EINKUENFTE"
End Sub




Sub Recherche_FichierMoisPrécédent_CopierFeuille_RefermerFichierMoisPrécédent()

Dim v_date, v_mois
Dim DV As String


        Dim message As String, title As String, default As String, Date_décompte As String
        
        Dim annee1 As String
        
        Application.ScreenUpdating = False
        
        
        chemin = "C:\Users\LACY\Documents\Yves\AG - PK Post"
                
retour:
    DV = InputBox("Meldung Quellensteuer vom MM.JJJJ?")
    Date_décompte = DV
    If DV = "" Then Exit Sub
    If Not (DateValide(DV)) Then
        MsgBox "Ungültiges Format": GoTo retour
    Else
    End If


        vmois = Left(Date_décompte, 2)
        annee = Right(Date_décompte, 4)
        Select Case vmois
            Case "0" & 2 To 10
            vmois1 = "0" & vmois - 1
            annee1 = annee
            Case Is = "0" & 1
            vmois1 = 12
            annee1 = annee - 1
            Case Is > 10
            vmois1 = vmois - 1
            annee1 = annee
            Case ""
            Exit Sub
        End Select
        Workbooks.Open Filename:=chemin & "\" & annee1 & "_" & vmois1 & "_Quellensteuer" & ".xls"
            
            v_BaseMoisPrécédent = ActiveWorkbook.Name
             
             
    Sheets("RepListeQuellensteuer").Copy After:=Workbooks( _
        "aaa_QUELLENSTEUER.xls").Sheets(1)
        
    Workbooks(v_BaseMoisPrécédent).Close
    Sheets("RepListeQuellensteuer (2)").Select
    Sheets("RepListeQuellensteuer (2)").Name = "Mois précédent"
    
    



''''' Mise en page des neuf lignes de titre

    Sheets("Mois précédent").Select
    Rows("1:9").Select
    Selection.Copy
    Sheets("RepListeQuellensteuer").Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    
    ' permet d'indiquer la date du décompte au travers de la InputBox
                                                               
             v_date = Left(Date_décompte, 2)
             Select Case v_date
             Case 1
             v_mois = "Januar"
             Case 2
             v_mois = "Februar"
             Case 3
             v_mois = "März"
             Case 4
             v_mois = "April"
             Case 5
             v_mois = "Mai"
             Case 6
             v_mois = "Juni"
             Case 7
             v_mois = "Juli"
             Case 8
             v_mois = "August"
             Case 9
             v_mois = "September"
             Case 10
             v_mois = "Oktober"
             Case 11
             v_mois = "November"
             Case 12
             v_mois = "Dezember"
             End Select
            Range("A7").Select
            Application.CutCopyMode = False
            ActiveCell.FormulaR1C1 = "Meldung Quellensteuer " & v_mois & " " & Right(Date_décompte, 4)
    
    
 ThisWorkbook.SaveAs Filename:=chemin & "\" & annee & "_" & vmois & "_QuellensteuerEssai" & ".xls"

    
    ' mise en page partielle
    Range("A8").Select
    ActiveCell.FormulaR1C1 = "Erstellt am: " & Date
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$10:$10"
        .RightHeader = "&8&P / &N"
        .LeftMargin = Application.InchesToPoints(0.2)
        .RightMargin = Application.InchesToPoints(0.16)
        .TopMargin = Application.InchesToPoints(0.59)
        .BottomMargin = Application.InchesToPoints(0.39)
        .HeaderMargin = Application.InchesToPoints(0.35)
        .FooterMargin = Application.InchesToPoints(0.16)
        .CenterHorizontally = True
        .Orientation = xlLandscape
        .PrintErrors = xlPrintErrorsDisplayed
    End With


End Sub

Function DateValide(DV)
Dim M, A
   DateValide = False
   On Error GoTo Fin
   If Len(DV) - Len(Application.Substitute(CStr(DV), ".", "")) <> 1 Or Len(DV) <> 7 Or InStr(1, DV, ".") <> 3 _
       Then Exit Function
   M = Left(DV, 2)
   A = Right(DV, 4)
   If A < 1900 Then Exit Function
   If M < 1 Or M > 12 Then Exit Function
   DateValide = True
Fin:
End Function

Sub BordsGris_Cadres()

' Change la couleur et les cadres de la ligne 10

    Sheets("RepListeQuellensteuer").Select
    With Range("A10:J10")
    With .Interior
        .ColorIndex = 15
        .Pattern = xlSolid
    End With
    .RowHeight = 28.5
    .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .WrapText = True
    .BorderAround ColorIndex:=xlAutomatic, LineStyle:=xlContinuous, Weight:=xlThin
    With .Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
End With
End Sub
Sub Assurés_disparus_depuis_mois_précédent()



  Application.Calculation = xlCalculationManual
  Dim LigFin As Long, ShtR As Worksheet
  ' Définir le nom de l'objet ShtR
  Set ShtR = Sheets("RepListeQuellensteuer")
  ' Supprimer la ligne total
  LigFin = ShtR.Range("G" & Rows.Count).End(xlUp).Row
  If Left(ShtR.Range("G" & LigFin).FormulaLocal, 6) = "=SOMME" Or Left(ShtR.Range("G" & LigFin).FormulaLocal, 6) = "=SUMME" Then
    Rows(LigFin).EntireRow.Delete
  End If
  
  Dim Cel As Range, Derlig As Long, LigF As Long
  '
  With Sheets("Mois précédent")
    Derlig = .Range("A" & Rows.Count).End(xlUp).Row
    For Each Cel In .Range("A11:A" & Derlig)
      LigF = FindLig(Cel)
      If LigF > 0 Then      ' Cette personne existe toujours
        
      Else                  ' Cette personne n'existe plus
        ShtR.Range("A" & LigFin) = Cel
        ShtR.Range("B" & LigFin) = Cel.Offset(0, 1)
        ShtR.Range("C" & LigFin) = Cel.Offset(0, 2)
        ShtR.Range("D" & LigFin) = Cel.Offset(0, 3)
        ShtR.Range("E" & LigFin) = Cel.Offset(0, 4)
        ShtR.Range("F" & LigFin) = Cel.Offset(0, 5)
        ShtR.Range("G" & LigFin) = "0"
        ShtR.Range("H" & LigFin) = "0"
        ShtR.Range("I" & LigFin) = " 0.00 ?"
        
        ' mise en forme partielle
    Rows("11:" & LigFin).Select      'utilisation de la variante LinFin (encore 2 fois plus loin)
    Selection.Font.Name = "Frutiger LT 45 Light"
    Rows("11:" & LigFin).Select
    Selection.Font.Size = 10
    With Selection
        .VerticalAlignment = xlTop
        .WrapText = True
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("A:A").ColumnWidth = 14
    Columns("B:B").ColumnWidth = 15
    Columns("D:D").ColumnWidth = 5.6
    Columns("E:E").ColumnWidth = 6.9
    Columns("F:F").ColumnWidth = 20
    Columns("G:G").ColumnWidth = 14
    Columns("H:H").ColumnWidth = 12
    Columns("I:I").ColumnWidth = 10.7
    Columns("J:J").ColumnWidth = 20
    Columns("A:A").HorizontalAlignment = xlGeneral
    Columns("D:D").HorizontalAlignment = xlGeneral
    Columns("F:F").HorizontalAlignment = xlGeneral
    Columns("G:G").NumberFormat = "#,##0.00"
    Columns("H:H").NumberFormat = "#,##0.00"
    
    Rows("11:" & LigFin).EntireRow.AutoFit
    
        ' Récupérer le numéro de la dernière ligne vide
        LigFin = ShtR.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
      End If
    Next Cel
  End With
  ' Efface la variable objet
  Set ShtR = Nothing
  Application.Calculation = xlAutomatic
End Sub

Function FindLig(VSearch)

' Function utilisée par la Sub Assurés_disparus_depuis_mois_précédent


  Application.Calculation = xlCalculationManual
  FindLig = 0
  With Sheets("RepListeQuellensteuer")
    On Error Resume Next
    FindLig = .Range("A:A").Find(What:=VSearch, LookAt:=xlWhole, SearchOrder:=xlByRows).Row
    On Error GoTo 0
  End With
  Application.Calculation = xlAutomatic

End Function

Sub Controle_montant_impôt()

Dim i As Integer, Lig As Long, tablo, x As Long

Application.ScreenUpdating = False
With Sheets("RepListeQuellensteuer")
    Lig = .Range("A65536").End(xlUp).Row ' Dernière ligne du tableau
    For i = Lig To 11 Step -1 ' Passage en revue
    If .Cells(i, 7) <> 0 And .Cells(i, 8) <> 0 Then
        If Round(.Cells(i, 8) / .Cells(i, 7), 3) <> 0.1 And Round(.Cells(i, 8) / .Cells(i, 7), 3) <> 0.045 Then
            x = x + 1
            tablo = Range(.Cells(i, 1), .Cells(i, 10))
            Rows(i).Delete
            Lig = .Range("A65536").End(xlUp).Row + 1
            Range(.Cells(Lig, 1), .Cells(Lig, 10)) = tablo
            .Cells(Lig, 9) = " %% ?"
        End If
    End If
    Next i
End With
Range("A" & (Lig - x + 1) & ":I" & Lig).Sort Key1:=Range("A" & (Lig - x + 1)), Order1:=xlAscending, Header:=xlNo


End Sub

Meilleures salutations.

skoobi · 19 Juin 2008

Re : Code VBA - Possibilité d'accélérer un code assez long ?

Bonjour,

Tout dépend de la quantité de données à traiter.
De plus, sans expliquer ce que fait la macro et sans le fichier.....

jmd2 · 19 Juin 2008

Re : Code VBA - Possibilité d'accélérer un code assez long ?

Hello à vous

Yvouille, tu fais de belles choses en code.
Mais pour encore progresser, pérenniser ton travail, il faut mettre des commentaires au sein du code.

Amicalement

*****

Staple1600 · 19 Juin 2008

Re : Code VBA - Possibilité d'accélérer un code assez long ?

Bonsoir à tous

->Yvouille
Est-on obligé de garder le nom des mois en allemand?

Yvouille · 20 Juin 2008

Re : Code VBA - Possibilité d'accélérer un code assez long ?

Bonjour à vous tous,

J'avais pensé ne placer sur le forum qu'une copie "épurée" de mes codes car j'ai beaucoup de commentaires pas toujours vraiment utiles et que ces codes nécessitent trois fichiers différents.

Mais selon votre demande, je place ici la totalité des documets nécessaires avec les codes non épurés.

Selon les fichiers fournis, seul le décompte du mois de janvier 2008 est possible (désolé pour tous les termes en allemand utilisés, mais ce travail sera utile à des collaborateurs germanophones). Quand la InputBox demande une date, il faut donc indiquer exclusivement "01.2008" (il se fait alors une comparaison avec l'ancien décompte de décembre 2007 qui est annexé).

De plus, il y a deux passage qui nécessitent des chemins bien précis afin de faire le lien avec les différents fichiers utilisés. Dans mes codes j'ai deux possibilités différentes, selon que je suis à la maison ou au travail (cf : "à Berne" et "à Fribourg").

J'ai également quelques questions supplémentaires parsemées dans mes codes. Si vous pouviez également y répondre ce serait génial.

Merci à tout ceux qui m'ont déjà fourni une première aide.

Bonne journée à tous.

Yvouille · 22 Juin 2008

Re : Code VBA - Possibilité d'accélérer un code assez long ?

Bonsoir à tous,

Je suis étonné de ne rececoir aucune aide à mon problème. N'y a-t-il vraiment aucune solution ?

Cordiales salutations.

Staple1600 · 22 Juin 2008

Re : Code VBA - Possibilité d'accélérer un code assez long ?

Bonsoir

Un conseil (souvent lu sur le forum)

Eviter au maximum les Select

Exemple:
Sheets("RepListeQuellensteuer (2)").Select
Sheets("RepListeQuellensteuer (2)").Name = "Mois précédent"

peut être remplacé par:

Sheets("RepListeQuellensteuer (2)").Name = "Mois précédent"

PS:
Comme tes chemins sont trés divers
chemin = "C:\Users\LACY\Documents\Yves\AG - PK Post"

Difficile de tester sans,
•soit créer des répertoires adéquats
•soit faire un Edition/Remplacer
Pour avoir des chemins du type C:\Temp

Staple1600 · 22 Juin 2008

Re : Code VBA - Possibilité d'accélérer un code assez long ?

Re bonsoir

Un exemple de modif

Code:

Sub Mise_en_place_bouton()
With Sheets("RepListeQuellensteuer").Buttons.Add(300, 0, 300, 80)
    .OnAction = "Tri_Mise_en_page_finale_Total_Enregistrement"
    .Characters.Text = "Tri et mise en page finale" & Chr(10) & "ligne 2" & Chr(10) & "ligne 3"
End With
Range("H11").End(xlDown).Offset(0, 2).Select
End Sub

Je te laise tester les modifications (car n'ayant pas ta configuration , je ne peux tester)

(J'ai mis des commentaire là ou j'ai modifié le code)

Bernard_XLD · 22 Juin 2008

Re : Code VBA - Possibilité d'accélérer un code assez long ?

Salut Yvouille, Stapple1600, le forum

Yvouille, tes codes sont déja trés optimisés
affichage désactivé
calcul auto désactivé
pas de sélect
pas d'évaluate
des boucles propres

il ne te reste plus qu'à tester plusieurs façons de coder ou jouer sur des astuces type

Code:

        ShtR.Range("A" & LigFin) = Cel
        ShtR.Range("B" & LigFin) = Cel.Offset(0, 1)
        ShtR.Range("C" & LigFin) = Cel.Offset(0, 2)
        ShtR.Range("D" & LigFin) = Cel.Offset(0, 3)
        ShtR.Range("E" & LigFin) = Cel.Offset(0, 4)
        ShtR.Range("F" & LigFin) = Cel.Offset(0, 5)

qui peut être avantageusement remplacé par

Code:

        ShtR.Range("A" & LigFin).Range("A1:F1").Value = Cel.Range("A1:F1").Value

sinon pour aller plus loin, il te faudra mettre en place un chrono pour tester les différentes façons de coder, j'en avais codé un justement pour cela dans l'ancien forum, je vais le rechercher.

Cordialement, A+

Staple1600 · 22 Juin 2008

Re : Code VBA - Possibilité d'accélérer un code assez long ?

Bonsoir Yeahou

Yeahou : Dans le premier fichier que j'ai regardé, il y avait des Select

(Voir mes modifs dans précédent message et la pièce jointe)

Bernard_XLD · 22 Juin 2008

Re : Code VBA - Possibilité d'accélérer un code assez long ?

salut staple1600

oui il y a des select, faut décidément que j'astique mes lunettes.
Au vu du code, je dirai qu'il a été écris par plusieurs personnes de niveaux différents ce qui m'a abusé en lecture rapide.

A+

Yvouille · 23 Juin 2008

Re : Code VBA - Possibilité d'accélérer un code assez long ?

Bonsoir Staple 1600, Bonsoir Yeahou, Bonsoir le Forum,

J’ai testé vos diverses propositions. En général elles font avancer le schmilblick de quelques pas, ce qui est fort appréciable.

Il a y par contre une proposition qui crée un problème :

MON ANCIEN CODE

Code:

    Sheets("Mois précédent").Select
    Rows("1:9").Select
    Selection.Copy
    Sheets("RepListeQuellensteuer").Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown

CETTE PROPOSITION EN REMPLACEMENT

Code:

    Sheets("Mois précédent").Rows("1:9").Copy
    Sheets("RepListeQuellensteuer").Rows("1:1").Insert Shift:=xlDown

Avec mon code, je vais chercher le fichier du décompte du mois précédent et je prépare le décompte du mois actuel. Avec le code proposé, ces mois sont inversés ; le mois actuel est indiqué dans la feuille « Mois précédent » et sur le décompte du mois actuel, j’ai la date du mois précédent (ou en tous cas les titres des décomptes son faux) ?!?!?!? Mais bon, le reste joue bien.

L'un dans l'autre, je dirais que ma procédure est passée grace à vous d'une vingtaine de secondes à une quinzaine ou à une douzaine environ.

Merci à tous deux pour vos propositions et votre aide.

Meilleures salutations.

Staple1600 · 23 Juin 2008

Re : Code VBA - Possibilité d'accélérer un code assez long ?

Re

Essaye comme cela en adaptant le nom des feuilles

Code:

Sub test()
'copie les lignes 1 à 9 de la feuille 1
'à partir de la première cellule vide en colonne A (feuille2)
Sheets(1).Rows("1:9").Copy Sheets(2).Range("A65536").End(xlUp).Offset(1, 0)
Application.CutCopyMode = xlCopy
End Sub

Yvouille · 24 Juin 2008

Re : Code VBA - Possibilité d'accélérer un code assez long ?

Bonsoir le forum, bonsoir Staple1600,

J'ai essayé ta proposition, mais j'ai toujours des résultats étranges.

Comme je ne pense pas que ce soit à ce niveau que mon code perd le plus de temps - mais bien plutôt dans les boucles - je préfère ne plus m'en soucier.

Pour moi on peut donc considéré ce fil comme résolu.

Merci encore à vous tous qui m'ont apporté leur soutien.

Effectuez une recherche sur Excel Downloads...

Code VBA - Possibilité d'accélérer un code assez long ?

Yvouille

XLDnaute Nouveau

skoobi

XLDnaute Barbatruc

jmd2

XLDnaute Accro

Staple1600

XLDnaute Barbatruc

Yvouille

XLDnaute Nouveau

Pièces jointes

Yvouille

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

Bernard_XLD

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

Bernard_XLD

XLDnaute Barbatruc

Yvouille

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

Yvouille

XLDnaute Nouveau

Discussions similaires

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