Optimisation code vba

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
J

justinev

XLDnaute Nouveau
Bonjour à tous,

Je planche actuellement sur une macro assez conséquente devant gérer beaucoup de données.

Le fichier est très lourd et j'aurai besoin de vos compétences pour optimiser et améliorer mon code.

C'est la première macro que je fais, j'ai encore beaucoup de chose à apprendre et j'en ai déjà baver pour écrire tous ça !

Son but est de collecter et trier des données, les répartir en fonction des différents transporteurs et d'aller calculer les couts grâce aux grilles tarifaires.

J'utilise trop le copier-coller et cela prend trop de temps et ne marche pas forcément, aurez-vous des idées d'amélioration, un moyen pour appeler mes formules "Index,equiv,equiv" de mes grilles tarifaires sans faire du copier-coller ?

En vous remerciant,

Bonne lecture et merci à tous !



Option Explicit
Option Base 1
Option Compare Text



Sub Macro()


Workbooks.Open Filename:="P:\Projet\PROJET CALCULS\export.MHTML"

Windows("export.MHTML").Activate

'Recherche et suppression des lignes inutiles

Dim i As Integer
For i = [A65000].End(xlUp).Row To 1 Step -1
If Not Cells(i, 42).Find(What:="PAL") Is Nothing Or _
Not Cells(i, 42).Find(What:="tou") Is Nothing Or _
Not Cells(i, 42).Find(What:="SACH") Is Nothing Or _
Not Cells(i, 1).Find(800) Is Nothing Or _
Not Cells(i, 42).Find(What:="Emballage Câble") Is Nothing Then Rows(i).Delete
Next i


'Tri des données par BL

ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A2:A4511" _
), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:CD4511")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'Copie des données "export" dans fichier "Projet" - A Mettre dans le même dossier


Range("A:A, E:E, Q:Q, AP:AP, AU:AU, AW:AW, BM:BM, BP:BP, CD:CD,AG:AG").Select
Selection.Copy

Windows("Copy of PROJET1.xlsm").Activate
Sheets("Données").Select
Columns("A:J").Select
ActiveSheet.Paste

Windows("export.MHTML").Activate
ActiveWindow.Close

'Fonction SI - Calculs du poids total des BL

[K2:K10000].Formula = "= IF(A2=A1,SUM(K1+F2),F2)"

[L2:L10000].Formula = "= IF(K3=F3,K2,"""")"

[K1] = "Poids"
[L1] = "Poids par BL"


'Filtre Schenker

Sheets("Données").Select
Columns("J:J").Select
Selection.AutoFilter
ActiveSheet.Range("$J$1:$J$2069").AutoFilter Field:=1, Criteria1:= _
"DB SCHENKER"

Range("A:L").Select
Selection.Copy Destination:=Sheets("Schenker").Range("A3")

'Filtre Ziegler

Sheets("Données").Select
Columns("J:J").Select
Selection.AutoFilter
ActiveSheet.Range("$J$1:$J$2069").AutoFilter Field:=1, Criteria1:= _
"TRANSPORTS ZIEGLER"

Range("A:L").Select
Selection.Copy Destination:=Sheets("Ziegler").Range("A3")


' Filtre LFB

Sheets("Données").Select
Columns("J:J").Select
Selection.AutoFilter
ActiveSheet.Range("$J$1:$J$2069").AutoFilter Field:=1, Criteria1:= _
"LA FLECHE BRESSANE"

Range("A:L").Select
Selection.Copy Destination:=Sheets("LFB").Range("A3")


'Calculs du cout BL/destination pour Schenker

Sheets("Schenker").Select
Range("L:L,H:H").Select
Selection.Copy

Workbooks.Open Filename:="P:\Projet\PROJET CALCULS\Grille tarifaire Schenker.xlsx"
Sheets("Poids calcul").Select
Range("A:A").Select
ActiveSheet.Paste

'Copier/ coller VALEUR grille tarifaire Schenker --> Projet

Sheets("Poids Calcul").Select
Columns("E:E").Select
Selection.Copy
Windows("Copy of PROJET1.xlsm").Activate
Sheets("Schenker").Select
Columns("M:M").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Windows("Grille tarifaire Schenker.XLSX").Activate
ActiveWindow.Close

'Calculs du cout BL/destination pour Ziegler

Sheets("Ziegler").Select
Range("H:H,L:L").Select
Selection.Copy

Workbooks.Open Filename:="P:\Projet\PROJET CALCULS\Grille tarifaire ZIEGLER.xlsx"
Sheets("Poids calcul").Select
Range("A:A").Select
ActiveSheet.Paste

'Copier/ coller VALEUR grille tarifaire Ziegler --> Projet

Sheets("Poids Calcul").Select
Columns("D😀").Select
Selection.Copy
Windows("Copy of PROJET1.xlsm").Activate
Sheets("Ziegler").Select
Columns("M:M").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Windows("Grille tarifaire ZIEGLER.XLSX").Activate
ActiveWindow.Close

'Calcul du cout moyen par BL


Dim V As Long, h As Long, LFin As Long
Dim Ws As Worksheet
Dim ColL As String, ColM As String
Dim tabl()
Dim NbMoy As Integer, LStart As Integer

Sheets("Schenker").Select

Set Ws = Sheets("Schenker")

'Colonne où se trouve les livraisons
ColL = "A"

'Colonne où se trouve les poids totals par BL
ColM = "M"

'Ligne de départ du tableau
LStart = 4

NbMoy = 0

'3 est la ligne de départ du tableau

With Ws

LFin = .Range(ColL & 65536).End(xlUp).Row

tabl = .Range(ColL & LStart & ":" & ColM & LFin).Value
ReDim Preserve tabl(UBound(tabl()), UBound(tabl(), 2) + 1)

For V = LBound(tabl()) To UBound(tabl())

For h = LBound(tabl()) To UBound(tabl())

If tabl(h, LBound(tabl(), 2)) = tabl(V, LBound(tabl(), 2)) Then

tabl(V, UBound(tabl(), 2)) = tabl(V, UBound(tabl(), 2)) + tabl(h, UBound(tabl(), 2) - 1)
NbMoy = NbMoy + 1

End If

Next h
If NbMoy > 0 Then tabl(V, UBound(tabl(), 2)) = tabl(V, UBound(tabl(), 2)) / NbMoy
NbMoy = 0

Next V
.Range(Cells(LStart, .Range(ColL & 1).Column), .Cells(LFin, Range(ColM & 1).Column + 1)).Value = tabl

End With

'Calcul du cout moyen par BL

Sheets("Ziegler").Select

Set Ws = Sheets("Ziegler")

'Colonne où se trouve les livraisons
ColL = "A"

'Colonne où se trouve les poids totals par BL
ColM = "M"

'Ligne de départ du tableau
LStart = 4

NbMoy = 0

'3 est la ligne de départ du tableau

With Ws

LFin = .Range(ColL & 65536).End(xlUp).Row

tabl = .Range(ColL & LStart & ":" & ColM & LFin).Value
ReDim Preserve tabl(UBound(tabl()), UBound(tabl(), 2) + 1)

For V = LBound(tabl()) To UBound(tabl())

For h = LBound(tabl()) To UBound(tabl())

If tabl(h, LBound(tabl(), 2)) = tabl(V, LBound(tabl(), 2)) Then

tabl(V, UBound(tabl(), 2)) = tabl(V, UBound(tabl(), 2)) + tabl(h, UBound(tabl(), 2) - 1)
NbMoy = NbMoy + 1

End If

Next h
If NbMoy > 0 Then tabl(V, UBound(tabl(), 2)) = tabl(V, UBound(tabl(), 2)) / NbMoy
NbMoy = 0

Next V
.Range(Cells(LStart, .Range(ColL & 1).Column), .Cells(LFin, Range(ColM & 1).Column + 1)).Value = tabl

End With


'Effacement des données dans la feuille données

Windows("Copy of PROJET1.xlsm").Activate
Sheets("Données").Select

Columns("J:J").Select
ActiveSheet.ShowAllData

[A:L].ClearContents

'Copy vers la "base"

Sheets("Schenker").Activate
Range("A3", Range("A4").End(xlToRight).End(xlDown)).Select
Selection.Copy Destination:=Sheets("Base").Range("A1")


Sheets("Ziegler").Activate
Range("A4", Range("A4").End(xlToRight).End(xlDown)).Select
Selection.Copy Destination:=Sheets("Base").Range("A4").End(xlDown).Offset(1, 0)

'Formule donneur ordre & code article

Sheets("Base").Activate

Range("O:O").FormulaLocal = "=D1&B1"

'Formule K/€

Range("P😛").FormulaLocal = "=ARRONDI.SUP(N1/G1;1)"
 
Trier par date Trier par votes
Re : Optimisation code vba

Bonsoir justinev,

Un fichier joint avec quelques données non confidentielles et le code à optimiser (pour faire des tests) inciterait sans doute plus de membres à vous aider.

extrait de la charte:
5 – La possibilité de joindre des fichiers est donnée sur ce forum. Ne pas hésiter à utiliser cette fonction, tout en veillant que les données soient bidons et donc qu’aucune donnée confidentielle, nominative ne soit dans le fichier.
Cliquez pour agrandir...

A plus 🙂,
 
Dernière édition:
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

G
  • Question Question
XL 2019 Sélectionner un fichier pour mettre à jour une base de données
Réponses
3
Affichages
211
sylvanu
sylvanu
X
  • Question Question
XL 2021 Transformation de données sur une ligne en plusieurs lignes
Réponses
5
Affichages
117
chris
chris
S
  • Résolu(e)
Microsoft 365 VBA Concaténer contenu de plusieurs cellules dans une seule avec séparateurs / évolutifs
Réponses
3
Affichages
114
spike29
S
David Aubert
Optimisation de code VBA
Réponses
5
Affichages
77
Cléa
Cléa
J
  • Question Question
Microsoft 365 Code VBA
Réponses
10
Affichages
794
jebibo
J
N
  • Résolu(e)
Microsoft 365 Macro copier/coller entre deux tableaux structurés
3 4 5
Réponses
66
Affichages
2 K
job75
job75
Chaton77
  • Résolu(e)
Microsoft 365 Vba : Transférer des données d'un tableau dans un autre fichier
Réponses
7
Affichages
481
Chaton77
Chaton77
P
  • Question Question
XL 2021 Ajout/adaptation de code VBA sur feuille qui en contient déjà
Réponses
3
Affichages
92
Pierreavecunp
P
A
  • Question Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
219
patricktoulon
patricktoulon
R
  • Question Question
XL 2021 Optimisation Code VBA
Réponses
10
Affichages
651
Dranreb
Dranreb
M
  • Question Question
Microsoft 365 Macro VBA supprimer une colonne
Réponses
5
Affichages
410
marie3107
M
M
  • Résolu(e)
XL 2016 Amélioration de code
Réponses
3
Affichages
596
M@xu3L
M
lynyrd
  • Question Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
599
AtTheOne
AtTheOne
L
  • Question Question
XL 2016 Actualisation d'une query via VBA
Réponses
5
Affichages
485
job75
job75
M
  • Question Question
Microsoft 365 Copier / coller avec mise en forme VBA
Réponses
0
Affichages
642
marie3107
M
T
  • Question Question
XL 2016 Optimisation d'une boucle
2 3
Réponses
30
Affichages
2 K
thivame
T
M
  • Résolu(e)
XL 2010 Code VBA pour Appeler un onglet avec texte + variable
Réponses
9
Affichages
825
Phil69970
Phil69970
S
  • Résolu(e)
Autres ActiveWorkbook.Worksheets("vierge").AutoFilter.Sort.SortFields.Clear
2
Réponses
23
Affichages
2 K
AtTheOne
AtTheOne
O
  • Question Question
XL 2010 aide sur code VBA collationnement de données
Réponses
10
Affichages
754
olivier388
O
xvella
  • Question Question
Microsoft 365 [Résolu] Vba Excel Mise à jour Colonne
Réponses
2
Affichages
521
xvella
xvella
Retour