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 ?
Meilleures salutations.
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.