VBA Code à "moderniser"
Bonjour à tous,
Je possède un code assez vieux et j'aimerais par tous les moyens essayer de le "moderniser", c'est-à-dire le rendre plus optimal (court et efficace). Cela me permet d'apprendre les différentes fonctionnalités de VBA par la même occasion.
Il s'agit d'un fichier que je me sert pour mettre à jour plusieurs fichiers. Bien sûr, je ne cherche qu'à l'optimiser donc pas besoin de trop se casser la tête
Merci beaucoup pour vos suggestions!
fizuaal
Bonjour Fizuaal le forum
ton code vaut ce qu'il vaut, mais c'est sur que pour le tester il faudrait au minimum joindre les 3 fichiers que la macro est sensée mettre à jour
Tous les activate sont inutiles, et surtout tous les fichiers doivent être ouvert avant de lancer la macro !!!! ?????
pas bon du tout pour moi!
a+
Papou
Merci paritec,
Oui les 3 fichiers sont déjà ouverts. J'ai une macro dans un autre fichier qui les ouvre au préalable, c'est pour cela que j'utilise des activate. Tu penses que les activate peuvent être remplacés?
Je ne souhaite pas mettre en pj les 3 autres fichiers car ils sont plus ou moins confidentiels...
Je cherchais à l'améliorer de la syntaxe, si au niveau de certaines lignes qui sont inutiles...
Merci,
Bonjour à tous,
Un début d'amélioration ... à tester sur des copies des fichiers.
Pour cette première étape, les fichiers doivent encore être ouverts au préalable.
Les noms des feuilles ("Feuil1") devront être adaptés aux noms réels des différents fichiers.
Code non testé ...
Sub mise_a_jour()
Dim MyRange As Range
Dim Lastligne As Double
Dim LastCol As Double
Dim r As Object
'verification des colonnes A des differents fichiers
With workboots("CAC40.XLS").Worksheets("Feuil1")
Nbligne = .Range("A" & Rows.Count).End(xlUp).Row
Set MyRange = .Range("A:A")
Maximum = Application.WorksheetFunction.Max(MyRange)
If .Cells(Nbligne, 1).Value = Maximum And .Cells(Nbligne - 1, 1).Value <> "" Then
Lastligne = .Range("A" & Rows.Count).End(xlUp).Row
Else
valcellule = .Cells(Nbligne, 1).Value
If MsgBox("En colonne A ligne " & Nbligne & " la cellule indique " & valcellule & _
" alors qu'elle ne correspond pas à la date d'aujourd'hui, voulez vous effacer " & _
"le contenu de cette cellule (si vous répondez non la macro s'arrêtera", vbYesNo, "") = vbYes Then
.Cells(Nbligne, 1) = ""
Lastligne = .Range("A" & Rows.Count).End(xlUp).Row
Else
Exit Sub
End If
End If
LastCol = .Cells(Lastligne, Columns.Count).End(xlToLeft).Column
.Range(.Cells(Lastligne, 1), .Cells(Lastligne, LastCol)).AutoFill Destination:=.Range(.Cells(Lastligne, 1), .Cells(Lastligne + 1, LastCol))
.Range(.Cells(Lastligne, 2), .Cells(Lastligne, 4)).Copy
.Cells(Lastligne, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Range(.Cells(Lastligne, 17), .Cells(Lastligne, 21)).Copy
.Cells(Lastligne, 17).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Cells(Lastligne, 27).Copy
.Cells(Lastligne, 27).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Cells(Lastligne, 33).Copy
.Cells(Lastligne, 33).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
If Weekday(.Cells(Lastligne, 1).Value) = 6 Then .Cells(Lastligne + 1, 1) = .Cells(Lastligne, 1).Value + 3
End With
With Workbooks("MATIF.XLS").Worksheets("Feuil1")
Nbligne2 = .Range("A" & .Rows.Count).End(xlUp).Row
Set MyRange = .Range("A1:A" & Nbligne2)
Maximum = CDate(Application.WorksheetFunction.Max(MyRange))
If .Cells(Nbligne2, 1).Value = Maximum And .Cells(Nbligne2 - 1, 1).Value <> "" Then
Lastligne2 = .Range("A" & Rows.Count).End(xlUp).Row
Else
valcellule2 = .Cells(Nbligne2, 1).Value
If MsgBox("En colonne A ligne " & Nbligne2 & " la cellule indique " & valcellule2 & _
" alors qu'elle ne correspond pas à la date d'aujourd'hui, voulez vous effacer " & _
"le contenu de cette cellule", vbYesNo, "") = vbYes Then
.Cells(Nbligne2, 1) = ""
Lastligne2 = .Range("A" & Rows.Count).End(xlUp).Row
Else
Exit Sub
End If
End If
LastCol2 = .Cells(Lastligne2, Columns.Count).End(xlToLeft).Column
.Range(.Cells(Lastligne2, 1), .Cells(Lastligne2, LastCol2)).AutoFill Destination:=.Range(.Cells(Lastligne2, 1), .Cells(Lastligne2 + 1, LastCol2))
.Range(.Cells(Lastligne2, 143), .Cells(Lastligne2, 145)).Copy
.Cells(Lastligne2, 143).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
If Weekday(.Cells(Lastligne2, 1).Value) = 6 Then .Cells(Lastligne2 + 1, 1) = .Cells(Lastligne2, 1).Value + 3
End With
With Workbooks("MAT8691.XLS").Worksheets("Feuil1")
Nbligne3 = .Range("A" & Rows.Count).End(xlUp).Row
Set MyRange = .Range("A1:A" & Nbligne3)
Maximum = Application.WorksheetFunction.Max(MyRange)
If .Cells(Nbligne3, 1).Value = Maximum And .Cells(Nbligne3 - 1, 1).Value <> "" Then
Lastligne3 = .Range("A" & Rows.Count).End(xlUp).Row
Else
valcellule3 = .Cells(Nbligne3, 1).Value
If MsgBox("En colonne A ligne " & Nbligne3 & " la cellule indique " & valcellule3 & _
" alors qu'elle ne correspond pas à la date d'aujourd'hui, voulez vous effacer " & _
"le contenu de cette cellule", vbYesNo, "") = vbYes Then
.Cells(Nbligne3, 1) = ""
Lastligne3 = .Range("A" & Rows.Count).End(xlUp).Row
Else
Exit Sub
End If
End If
LastCol3 = .Cells(Lastligne3, Columns.Count).End(xlToLeft).Column
.Range(.Cells(Lastligne3, 1), .Cells(Lastligne3, LastCol3)).AutoFill Destination:=.Range(.Cells(Lastligne3, 1), .Cells(Lastligne3 + 1, LastCol3))
.Cells(Lastligne3, 2).Copy
.Cells(Lastligne3, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
If Weekday(.Cells(Lastligne3, 1).Value) = 6 Then .Cells(Lastligne3 + 1, 1) = .Cells(Lastligne3, 1).Value + 3
End With
End Subric