Optimisation code vba

[justinev]

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)"

 

[mapomme]

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.

A plus ,