XL 2016 Optimisation MACROS

laurent950 à dit:

Re @Michest

Oui j'ai Oublier de desactiver la Msgbox
MsgBox ObjRaz.ClearContents ---- Replacer par ----->> ObjRaz.ClearContents

J'ai créer une procédure pour effacer bien plus rapides :
[{"Extract_Inters","A2:Z10000"}]
Nom de la Feuille Excel = "Extract_Inters"
Plage a effacer = "A2:Z10000"
Il suffit juste de remplire dans la variable tableau T pour chacunes des feuilles la plage a effacer :
Exemple 1 : Pour la Feuille excel (Nom F1)
T = Array([{"F1","A2:C40"}], [{"F1","W3:Z1087"}], [{"F1","E32:J80"}],
Exemple 1 : Pour la Feuille excel (Nom F1 et F2 et F3)
T = Array([{"F1","A2:C40"}], [{"F2","W3:Z1087"}], [{"F3","E32:J80"}],
La procédure de la boucle la variable i est instancier a Byte soit 0 à 255
255 Plage c'est déjà pas mal ! une plage de la Feuil c'est l'adresse : "A2:C40"
A tester est adaptable à convenance.

module 1 pour le bouton RAZ

VB:

Sub RAZ()
Dim T As Variant
T = Array([{"Extract_Inters","A2:Z10000"}], [{"InterA","A2:Z10000"}], [{"InterN","A2:Z10000"}], [{"Extraction données INTER","A2:M10000"}])
RAZSelect T
'Sheets("Extract_Inters").Range("A2:Z10000").ClearContents
'Sheets("InterA").Range("A2:Z10000").ClearContents
'Sheets("InterN").Range("A2:Z10000").ClearContents
'Sheets("Extraction données INTER").Activate
'Range("A2:M10000").ClearContents
'Range("A1").Select
End Sub

'
et
'

VB:

Sub RAZ()
Dim T As Variant
T = Array([{"Extract_DI","A2:Z10000"}], [{"Infos DI","A2:H10000}])
RAZSelect T
'Sheets("Extract_DI").Range("A2:Z10000").ClearContents
'Sheets("Infos DI").Range("A2:H10000").ClearContents
End Sub

'
et
'

VB:

Sub RAZ()
Dim T As Variant
T = Array([{"Extraction données OCCU","A2:H10000"}], [{"OccuA","A2:H10000}])
RAZSelect T
'Sheets("Extraction données OCCU").Range("A2:Z10000").ClearContents
'Sheets("OccuN").Range("A2:H10000").ClearContents
'Sheets("OccuA").Range("A2:H10000").ClearContents
End Sub

'
' Procédure RAZSelect
'
' Crer une Fonction

VB:

Sub RAZSelect(ByRef T As Variant)
Dim F As Worksheet
Dim ObjRaz As Range
Dim i As Byte
    For i = LBound(T) To UBound(T)
        Set F = Worksheets(CStr(T(i)(1)))
        Set ObjRaz = F.Range(CStr(T(i)(2)))
        ObjRaz.ClearContents
    Next i
End Sub

Cliquez pour agrandir...

Staple1600 à dit:

Re

Ne pas oublier que mon code sent la pomme (enfin mapomme )

Il te reste plus qu'à effacer ton précédent message qui contient de la fake news comme dirait Donald

Cliquez pour agrandir...

mais je suis partis d'un problème d'optimisation de macro qui fonctionne pas terrible mais qui fonctionne avec de la prog. faite par l'enregistreur

Cliquez pour agrandir...

laurent950 à dit:

Re @Staple1600
je vais regarder le Module 2

Cliquez pour agrandir...

Staple1600 à dit:

Bonsoir

=>Michest

C'est par là que nous sommes tous passés au départ
C'est une très bonne école

Cliquez pour agrandir...

Staple1600 à dit:

Bonsoir le fil,


Effectivement, il y avait un petit souci
Ci-dessous, une macro juste explicative (A TESTER SUR UN CLASSEUR VIERGE, avec 3 feuilles: Feuil1, Feuil2 et Feuil3)
Juste pour voir comment cela fonctionne
Il faut d'abord lancer la macro Créér_Test()
NB: J'espère que les commentaires sont suffisamment claires.

VB:

Dim f As Workbook
Sub Créer_TEST()
Feuil1.Range("A1:C10") = "=ADDRESS(ROW(),COLUMN(),4)"
Feuil1.Range("A1:C3").Interior.ColorIndex = 20
Feuil2.Range("A1:C25") = "=COS(COLUMN()+ROW())"
Feuil2.Range("A1:B5").Interior.ColorIndex = 12
Feuil3.Range("A1:E10") = "=ROW()^COLUMN()"
Feuil3.Range("A1:C3").Interior.ColorIndex = 6
End Sub
Sub RAZ()
'ici on effacera la plage A1:C3 des feuilles Feuil1 et Feuil3
Effacer "A1:C3", "Feuil1", "Feuil3"
'ici on effacera la plage A1:B5 de la feuille Feuil2
Effacer "A1:B5", "Feuil2"
End Sub

Private Sub Effacer(r As String, ParamArray vF() As Variant)
Set f = ThisWorkbook
If UBound(vF) < 0 Then Exit Sub
f.Sheets(vF).Select: Range(r).Select: Selection.ClearContents: f.Sheets(vF(0)).Select
End Sub

Cliquez pour agrandir...

Staple1600 à dit:

Bonsoir le fil,


Effectivement, il y avait un petit souci
Ci-dessous, une macro juste explicative (A TESTER SUR UN CLASSEUR VIERGE, avec 3 feuilles: Feuil1, Feuil2 et Feuil3)
Juste pour voir comment cela fonctionne
Il faut d'abord lancer la macro Créér_Test()
NB: J'espère que les commentaires sont suffisamment claires.

VB:

Dim f As Workbook
Sub Créer_TEST()
Feuil1.Range("A1:C10") = "=ADDRESS(ROW(),COLUMN(),4)"
Feuil1.Range("A1:C3").Interior.ColorIndex = 20
Feuil2.Range("A1:C25") = "=COS(COLUMN()+ROW())"
Feuil2.Range("A1:B5").Interior.ColorIndex = 12
Feuil3.Range("A1:E10") = "=ROW()^COLUMN()"
Feuil3.Range("A1:C3").Interior.ColorIndex = 6
End Sub
Sub RAZ()
'ici on effacera la plage A1:C3 des feuilles Feuil1 et Feuil3
Effacer "A1:C3", "Feuil1", "Feuil3"
'ici on effacera la plage A1:B5 de la feuille Feuil2
Effacer "A1:B5", "Feuil2"
End Sub

Private Sub Effacer(r As String, ParamArray vF() As Variant)
Set f = ThisWorkbook
If UBound(vF) < 0 Then Exit Sub
f.Sheets(vF).Select: Range(r).Select: Selection.ClearContents: f.Sheets(vF(0)).Select
End Sub

Cliquez pour agrandir...

laurent950 à dit:

Bonjour @Michest
Module 1

VB:

Sub RAZ()
Dim T() As Variant
Dim ObjRaz As Range
Dim i As Byte
    T = Array("Extract_Inters", "InterA", "InterN", "Extraction données INTER")
    For i = LBound(T) To UBound(T)
        Set T(i) = Worksheets(T(i))
        If i < 3 Then
            Set ObjRaz = T(i).Range("A2:Z10000"): ObjRaz.ClearContents
        Else
            Set ObjRaz = T(i).Range("A2:M10000"): ObjRaz.ClearContents
        End If
    Next i
End Sub

Module 2

VB:

'   Traitement colonne G
    Dim RgnOO As Range
        Set RgnOO = Range("O:O")
    Dim RgnGG As Range
        Set RgnGG = Range("G:G")
    Dim RgnPP As Range
        Set RgnPP = Range("P:P")
    RgnOO.ClearContents
    RgnGG.Copy: RgnOO.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
               SkipBlanks:=False, Transpose:=False
    RgnPP.Copy: RgnGG.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
               SkipBlanks:=False, Transpose:=False
    RgnGG.EntireColumn.AutoFit
    Application.CutCopyMode = False

Le sous détaille de la modification du module 2 :
avec cela vous pouvez déjà en optimisé d'autres passage de votre Projet VBA

VB:

'Traitement colonne G
dim RgnOO as range
    set RgnOO = Range("O:O")
dim RgnGG as range
    set RgnGG = Range("G:G")
dim RgnPP as range
    set RgnPP = Range("P:P")
'
'Columns("O:O").Select :Selection.ClearContents
    RgnOO.ClearContents
'Columns("G:G").Select :Selection.Copy
'Columns("O:O").Select
'Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
'SkipBlanks:=False, Transpose:=False
    RgnGG.Copy :RgnOO.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
               SkipBlanks:=False, Transpose:=False
'Columns("P:p").Select
'Application.CutCopyMode = False
'Selection.Copy
'Columns("G:G").Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
':=False, Transpose:=False
    RgnPP.Copy :RgnGG.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
               SkipBlanks:=False, Transpose:=False
'Columns("O:O").Select
'Selection.ClearContents

VB:

[B]' Copie Astreinte colonne M vers colonne H[/B]
dim RgnMM as range
    set RgnMM = Range("M:M")
dim RgnHH as range
    set RgnHH = Range("H:H")
    RgnMM.Copy :RgnHH.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
               SkipBlanks:=False, Transpose:=False
Columns("G:G").EntireColumn.AutoFit
RgnGG.EntireColumn.AutoFit

Cliquez pour agrandir...

laurent950 à dit:

Bonjour @Michest
Le code produit par l'enregistreur de Macro VBA est correcte, il faut interprété le code et le récrire mais pour cela il faut des connaissance en VBA ce que j'ai mais aussi des connaissance métier (ce que vous avez) et je ne serais pas écrire le code VBA Optimisé pour arriver à votre résultat. Donc c'est de repartir du Poste 1 et faire la Macro en Pas à Pas pour comprendre les données d'entrées et le chemin jusqu'au donnée de sortie (puis écrire le Code avec : Variables Tableaux, pour les doublons (Utilisé une classe Collection ou un dictionnaire "scripting.dictionary" puis pour la gestion des tries utiliser une fonction QuickShort, ect.

Cliquez pour agrandir...

Michest à dit:

Bonjour,


Bonjour Staple1600,

J'ai tester ton exemple f1,f2,f3 avec zone colorée à effacer cela fonctionne.
Maintenant à voir dans mon classeur...Il faut que j'adapte sachant que dans ma prog. ce n'est pas la partie la plus ralentissant.

Cliquez pour agrandir...