Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2016 Optimisation MACROS

Michest94

XLDnaute Occasionnel
Bonjour,

Je vous sollicite pour votre aide afin d'optimiser 3 fichiers, un fichier 'Interventions' (cf fichier joint) qui me permet d'extraire des données en brut.
Puis après une remise en forme de ces données, elles vont être exportées vers un logiciel tiers ( powerBI ).
Actuellement tout fonctionne mais une partie des macros ont été réalisées avec l'enregistreur de macros d'où des latences ...

Une optimisation sur optimisation sur partie codifié en gras :

module 1 pour le bouton RAZ
Sub RAZ()
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

module 2 la partie
'
' *** Niveau ARBO (fils vers père) ***
'
'Traitement colonne G
Columns("O:O").Select
Selection.ClearContents
Columns("G:G").Select
Selection.Copy
Columns("O:O").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Columns("P").Select
Application.CutCopyMode = False
Selection.Copy
Columns("G:G").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("O:O").Select
'Selection.ClearContents
Columns("G:G").EntireColumn.AutoFit

Module 4 ( optimisation complète )

Merci pour votre aide,

*******************************************************************************************
Eventuellement dans le même but j'ai 2 autres fichiers à optimiser 'DI' et 'Occupations'
optimisation sur partie codifié en gras
*******************************************************************************************

***Fichier 'DI'***
Module 1

Option Explicit

Dim w1 As Workbook, f1 As Worksheet, liste1, liste2
Dim i&, j&, lgn&, flag&
Sub RAZ()
Sheets("Extract_DI").Range("A2:Z10000").ClearContents
Sheets("Infos DI").Range("A2:H10000").ClearContents
End Sub


Sub Recuperer()
[Extract_DI!2:65536].EntireRow.Delete
flag = 0
For Each w1 In Workbooks
For Each f1 In w1.Worksheets
If w1.Name <> ActiveWorkbook.Name Then
If f1.Range("A1") = "Destinataire de la DI" Then
liste1 = Array(6, 3, 7, 13, 4, 1, 18)
liste2 = Array(1, 2, 3, 4, 5, 6, 7)

For i = 2 To f1.Range("A" & Rows.Count).End(xlUp).Row
lgn = Range("A" & Rows.Count).End(xlUp)(2).Row
For j = 0 To 6
If j = 0 Then
Cells(lgn, liste2(j)).Value = CDate(f1.Cells(i, liste1(j)).Value)
Else
Cells(lgn, liste2(j)).Value = f1.Cells(i, liste1(j)).Value
End If
Cells(lgn, 1).NumberFormat = "[$-fr-FR]mmm-yy;@"
Next j
Next i
flag = 1
End If

End If
Next f1
Next w1
If flag = 0 Then
MsgBox "Le fichier source doit être ouvert.", 16
Exit Sub
End If

'
' Traitement A - HA
'

'
Sheets("A-HA").Select
Range("A2").Select
Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False
Columns("A:B").Select
Selection.Copy
Sheets("Extract_DI").Select
Columns("L:M").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select

'
' TRI numéros interventions A-Z colonne B et L
'

'
Range("B2").Select
ActiveWorkbook.Worksheets("Extract_DI").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Extract_DI").Sort.SortFields.Add Key:=Range( _
"B2:B303"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Extract_DI").Sort
.SetRange Range("A1:H10000")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("L1:M1").Select
Selection.AutoFilter
Selection.AutoFilter
ActiveWorkbook.Worksheets("Extract_DI").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Extract_DI").AutoFilter.Sort.SortFields.Add Key:= _
Range("L1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Extract_DI").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select

'
' Copie Astreinte colonne M vers colonne H
'

'
Columns("M:M").Select
Selection.Copy
Columns("H:H").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
End Sub

Module 2 ->ok

Module 3
Sub PowerBI_DI()
'
' PowerBI_DI Macro
'

'
Cells.Select
Selection.Copy
Sheets("Infos DI").Select
Cells.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells.EntireColumn.AutoFit
Cells.EntireColumn.AutoFit
Cells.EntireColumn.AutoFit
Cells.EntireColumn.AutoFit
Cells.EntireColumn.AutoFit
Cells.EntireColumn.AutoFit
Cells.EntireColumn.AutoFit
Range("A1").Select
Sheets("Extract_DI").Select
Range("A1").Select
Application.CutCopyMode = False

Columns("A:A").Select
Selection.Copy
Sheets("Infos DI").Select
Columns("A:A").Select
ActiveSheet.Paste
Sheets("Extract_DI").Select
Range("A1").Select
Application.CutCopyMode = False
End Sub


***Fichier 'Occupations'***
Module 1

Option Explicit

Dim w As Workbook
Dim flag&, colA, colB, l&
Sub RAZ()
Sheets("Extraction données OCCU").Range("A2:Z10000").ClearContents
Sheets("OccuN").Range("A2:H10000").ClearContents
Sheets("OccuA").Range("A2:H10000").ClearContents
End Sub
Sub Importer()

flag = 0
Range("A1").CurrentRegion.Offset(1, 0).ClearContents
For Each w In Workbooks
If w.Sheets(1).Range("B1") = "Libellé" Then
colA = Array(10, 15, 8, 3, 17, 2, 5)
colB = Array(1, 2, 3, 4, 5, 6, 7)
With w.Sheets(1)
For l = 0 To 6
.Range(.Columns(colA(l)), .Columns(colA(l))).Copy Cells(1, colB(l))
Next l
End With
flag = 1
Exit For
End If
Next w
If flag = 0 Then
MsgBox "Le fichier source doit être ouvert.", 16
End If

'
' RAZ_OccuA_HA Macro
'

'
Sheets("OccuA").Select
Cells.Select
Selection.ClearContents
Range("A1").Select
Sheets("OccuN").Select
Cells.Select
Selection.ClearContents
Range("A1").Select
Sheets("Extraction données OCCU").Select

End Sub

Module 2 -> ok

Module 3
Sub OccuA()
'
' OccuA Macro
'

'
ActiveSheet.Range("$A$1:$G$65536").AutoFilter Field:=3, Criteria1:=Array( _
"ASTR_DIST_PAYE", "ASTR_DIST_RECUP", "ASTR_SPLACE_PAYE", "ASTR_SPLACE_RECUP"), _
Operator:=xlFilterValues
Cells.Select
Selection.Copy
Sheets("OccuA").Select
Cells.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Sheets("Extraction données OCCU").Select
ActiveSheet.Range("$A$1:$G$65536").AutoFilter Field:=3
Range("A1").Select
'Application.CutCopyMode = False
End Sub
Sub OccuHA()
'
' OccuHA Macro
'

'
ActiveSheet.Range("$A$1:$G$65536").AutoFilter Field:=3, Criteria1:=Array( _
"NORMAL", "SUPP_PAYE", "SUPP_RECUPE"), Operator:=xlFilterValues
Cells.Select
Selection.Copy
Sheets("OccuN").Select
Cells.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Range("A1").Select
Sheets("Extraction données OCCU").Select
ActiveSheet.Range("$A$1:$G$65536").AutoFilter Field:=3
Range("A1").Select
Application.CutCopyMode = False
End Sub
 

Pièces jointes

  • Interventions.xlsm
    957.6 KB · Affichages: 54
Solution
Bonjour Michest, bonjour le forum,

Bon... On va y aller par étapes....

• Module1
je ne vois rien à modifier

• Module 2
Règle d'or VBA : éviter autant que possible les Select/Activate qui ne font que ralentir l'exécution du code et sont source de plantages :

Code: 
Dim OE As Worksheet

Set OE = Worksheets("Extraction données INTER")
OE.Columns("O:O").ClearContents
OE.Columns("G:G").Copy
OE.Columns("O:O").PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
OE.Columns("P:P").Copy
OE.Columns("G:G").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
OE.Columns("G:G").AutoFit

Pour le reste suivre la règle...
Trier par date Trier par votes

Robert

XLDnaute Barbatruc
Repose en paix
Bonjour Michest, bonjour le forum,

Bon... On va y aller par étapes....

• Module1
je ne vois rien à modifier

• Module 2
Règle d'or VBA : éviter autant que possible les Select/Activate qui ne font que ralentir l'exécution du code et sont source de plantages :

Code: 
Dim OE As Worksheet

Set OE = Worksheets("Extraction données INTER")
OE.Columns("O:O").ClearContents
OE.Columns("G:G").Copy
OE.Columns("O:O").PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
OE.Columns("P:P").Copy
OE.Columns("G:G").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
OE.Columns("G:G").AutoFit

Pour le reste suivre la règle.
Sheets("Untel").Select
Range("Une_plage").Select
Selection.Blablabla
Sheets("Untel").Range("Une_plage").Blabla

Utilise Select uniquement si tu veux sélectionner
Sheets("Untel").Select
Range("Une_plage").Select
Voire même :
Sheets("Untel").Select
Sheets("Untel").Range("Une_plage").Select
si le code est lancé à partir d'un bouton placé dans un autre onglet...

Pour l'AutoFit, en une seule fois puisque les colonnes se suivent :
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit

Columns("A:F").AutoFit
 
Dernière édition:
Vote positif 0 Vote négatif
Solution

Michest94

XLDnaute Occasionnel
 
Vote positif 0 Vote négatif

Michest94

XLDnaute Occasionnel
Bonjour Robert,

Merci pour tes conseils je vais tenter de décortiquer tout ca c'est pas gagné.
D'où l'idée du fichier en pièce jointe me servant de guide pour le report sur les 2 autres.

Juste une petite question que je me pose, ton profil (avatar) me dit quelque chose par rapport à une aide très précieuse que tu mas apporté sur un formulaire d'enregistrement ( Plans autocad, ...)
Merci à toi,
@+
 
Vote positif 0 Vote négatif

laurent950

XLDnaute Barbatruc
Bonjour @Robert , @Michest
A toutes hasard est ce que vous connaissais la commande VBA qui permet de faire basculer l'écrans d'affichage :
Exemple : A la fin du lancement d'une Macro Excel Via Autocad (Les 2 applications ouvertes)
Depuis l'application Excel (Ma dernière ligne de Code Rend actif l'application Autocad)
une sorte de switch entre application.
se serais cette commande :
depuis Excel pour Ouvrir (le dessin) Mais je veux que rendre visible à lécrans cette application sans ouvrir le document.
L'idée ci-dessous (à adapter) si vous savez comment swicher entre affichage d'application

ThisDrawing.Application.Documents.Open strFichier ' Ouverture du dessin

Mais le dessin est déjà Ouvert (l'application aussi)
Cdt
 
Vote positif 0 Vote négatif

Robert

XLDnaute Barbatruc
Repose en paix
Bonjour le fil, bonjour le forum,

Désolé Laurent, je ne sais pas. Je pense malgré tout que c'est relativement simple et je te propose de créer un post spécifique. Tu risques d'avoir des réponses très vite...
 
Vote positif 0 Vote négatif

Staple1600

XLDnaute Barbatruc
Bonsoir le fil

Pour le module 1, je propose ceci
(inspiré d'un code de mapomme)
VB: 
Sub RAZ()
Effacer "A2:Z10000", "InterA", "InterN", "Extract_Inters"
Effacer "A2:M10000", "Extraction données INTER"
End Sub
Private Sub Effacer(r As String, ParamArray vF())
If UBound(vF) < 0 Then Exit Sub
ThisWorkbook.Sheets(vF).Select 0: Range(r).Select: Selection.ClearContents
ThisWorkbook.Sheets(vF(0)).Select
End Sub
NB: Test OK sur Excel 2013
 
Vote positif 0 Vote négatif

Michest94

XLDnaute Occasionnel
Bonsoir,

Module 1 : test ok
Maintenant le gros du gros est le module 2 et 4.
Je vais essayé dés que je peux d'appliqué les conseils de Robert.
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

  • Question
Autres fenêtre "Publication"
Réponses
10
Affichages
380
ph.vanne
H
  • Résolu(e)
XL 2016 Copier cellule dans un autre onglets
2
Réponses
16
Affichages
272
Phil69970
G
  • Question
XL 2019 Sélectionner un fichier pour mettre à jour une base de données
Réponses
3
Affichages
134
sylvanu
M
  • Question
XL 2021 VBA Excel Erreur 2023
Réponses
2
Affichages
148
MICHIS
M
M
  • Question
Microsoft 365 deux macros succesives et un bouton
2
Réponses
16
Affichages
656
Phil69970
  • Résolu(e)
XL 2021 Exécuter une macro sur plusieurs feuilles
Réponses
9
Affichages
256
micie1509
R
  • Résolu(e)
XL 2019 creer une macro pour copier des info d un onglet a un autre dans le meme classeur
Réponses
4
Affichages
505
robpellan52
R
N
  • Résolu(e)
Microsoft 365 Macro copier/coller entre deux tableaux structurés
3 4 5
Réponses
66
Affichages
1 K
job75
  • Question
XL 2021 Code manufacturier et fabricant (Ram) suite projet en cours ( à tester s'il vous plait )
2 3
Réponses
42
Affichages
980
TooFatBoy
G
  • Résolu(e)
XL 2013 copier coller valeur d'une colonne dynamique
Réponses
13
Affichages
607
gwenn49
G
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…