Bonjour à toutes et à tous,
j'ai une macro que j'ai faite avec votre aide, elle fonctionne comme je le souhaite, mais elle tourne pendand 1 H environ. J'aimerais savoir si on peut l'améliorer. Elle trourne sur 3 onglets ( 2 de 8000 lignes et 1 de 50000). Je sais çà fait beaucoup.
Merci de votre aide
@+
j'ai une macro que j'ai faite avec votre aide, elle fonctionne comme je le souhaite, mais elle tourne pendand 1 H environ. J'aimerais savoir si on peut l'améliorer. Elle trourne sur 3 onglets ( 2 de 8000 lignes et 1 de 50000). Je sais çà fait beaucoup.
Merci de votre aide
@+
Code:
Sub Suivi_des_PO()
Dim i%
Dim j As Range
Dim l As Range
Dim c As Range
Dim r As Range
Dim d As Range
Dim e As Range
Dim f As Range
Dim Départ As String
Dim Somme&
With Worksheets("TradeCard")
Application.ScreenUpdating = False
Set l = .Range("D65536").End(xlUp)
Do While l.Row > 1
If InStr(l, "M") <> 1 Then
l.EntireRow.Delete
Set l = .Range("D65536").End(xlUp)
Else: Set l = l(0, 1)
End If
Loop
.Columns(5).Insert
.Cells(1, 5) = "PO-LG"
Set f = .Range("E2")
Do While f.Offset(0, -1) <> ""
f = Split(f(1, 0), "/")(0) & "-" & Mid(.Range("G" & f.Row).Value, 4, 3)
Set f = f.Offset(1, 0)
Loop
End With
'supprime les colonnes de A,B,D,E,F,G,H,M,S,U,V,W
With Worksheets("5-9-12")
.Range("A:B,D:D,J:K,M:M,S:S,U:W").Delete
'supprime toutes les lignes dont les cellules de C ne commence pas par M
Set l = .Range("C65536").End(xlUp)
Do While l.Row > 1
If InStr(l, "M") <> 1 Then
l.EntireRow.Delete
Set l = .Range("C65536").End(xlUp)
Else: Set l = l(0, 1)
End If
Loop
'insertion d'une colonne pour constituer ma valeur
.Columns("D").Insert
.Columns("H").Insert
.Columns("I").Insert
.Columns("J").Insert
.Columns("K").Insert
.Columns("L").Insert
.Columns("M").Insert
.Columns("N").Insert
.Columns("M").Insert
.Columns("N").Insert
.Columns("O").Insert
.Cells(1, 2) = "Fournisseur"
.Cells(1, 4) = "PO-LG"
.Cells(1, 8) = "Qtés RCT-PO"
.Cells(1, 9) = "Qté ASN"
.Cells(1, 10) = "Date RCT-PO"
.Cells(1, 11) = "Qté RCT-C3D"
.Cells(1, 12) = "Date RCT-C3D"
.Cells(1, 13) = "Qté En Transit"
.Cells(1, 14) = "Date Prévue-C3D"
.Cells(1, 15) = "Product Line"
.Cells(1, 16) = "CDC FY"
.Cells(1, 17) = "CDC Period"
'concatène C et "-" et S
Set c = .Range("D2")
Do While c.Offset(0, -1) <> ""
c = c(1, 0) & "-" & Format(c(1, 19), "000")
Set c = c.Offset(1, 0)
Loop
End With
'prise en compte de la page "5-17"
'With Sheets("5-17")
'remplace ? par Transit.
With Sheets("5-17").Range("AB:AB")
Set j = .Find(What:="?", LookIn:=xlValues, lookat:=xlWhole)
If Not j Is Nothing Then
Do
j.Value = "Transit"
Set j = .FindNext(j)
Loop While Not j Is Nothing
End If
'prise en compte de la page "5-17"
With Sheets("5-17")
'insertion d'une colonne
.Columns(6).Insert
.Cells(1, 6) = "PO-LG"
'transforme les cellules texte en nombre. Tester vide
For i = 2 To .Range("K65536").End(xlUp).Row
.Cells(i, 11) = CDbl(Trim(Replace(Cells(i, 11), ".", ",")))
Next
'supprime toutes les lignes dont les cellules de E ne commence pas par M
Set l = .Range("E65536").End(xlUp)
Do While l.Row > 1
Application.StatusBar = l.Row
If InStr(l, "M") <> 1 Then
l.EntireRow.Delete
Set l = .Range("E65536").End(xlUp)
Else: Set l = l(0, 1)
End If
Loop
'concatène E et "-" et Hf
Set d = .Range("F2")
Do While d.Offset(0, -1) <> ""
d = d(1, 0) & "-" & Format(d(1, 3), "000")
Set d = d.Offset(1, 0)
Loop
End With
Set c = Worksheets("5-9-12").Range("D" & Worksheets("5-9-12").Range("D65536").End(xlUp).Row)
Do While c.Row > 1
Somme& = 0
With Worksheets("5-17").Range("F2:F" & Worksheets("5-17").Range("F65536").End(xlUp).Row)
Set d = .Find(c)
If Not d Is Nothing Then
Départ = d.Address
Do
Somme& = d(1, 6) + Somme&
c(2, 1).EntireRow.Insert
c(2, 0) = "N° ASN"
'n° d'ASN OK
c(2, 1) = d(1, 26)
'qt dans l'ASN OK
c(2, 6) = d(1, 6)
'date rct-po
c(2, 7) = d(1, 5)
'date rct-c3d
c(2, 9) = d(1, 19)
If d(1, 24) = "Transit" Then
c(2, 8) = 0
Else: c(2, 8) = d(1, 6)
End If
'Qté réceptionnée C3D
If d(1, 20) = "?" Then
c(2, 8) = 0
ElseIf d(1, 6) = d(1, 18) Then
c(2, 8) = d(1, 6)
ElseIf d(1, 6) - d(1, 18) <> 0 Then
c(2, 8) = d(1, 6) - d(1, 18)
Else
End If
'date prévue c3d
c(2, 11) = d(1, 24)
If d(1, 24) = "Transit" Then
c(2, 11) = d(1, 23)
Else: c(2, 10) = d(1, 18)
End If
'Qté en transit
If c(2, 6) = c(2, 8) Then
c(2, 10) = 0
Else: c(2, 10) = d(1, 18)
End If
Set d = .FindNext(d)
Loop While Not d Is Nothing And d.Address <> Départ
End If
End With
With Worksheets("TradeCard").Range("E2:E" & Worksheets("TradeCard").Range("E65536").End(xlUp).Row)
Set f = .Find(c)
If Not f Is Nothing Then
Départ = f.Address
Do
c(1, 12) = f(1, 14)
c(1, 13) = f(1, 46)
c(1, 14) = f(1, 47)
Loop While Not f Is Nothing And f.Address <> Départ
End If
End With
'on fait le total de tous les ASN
c(1, 5) = Somme&
Set c = c(0, 1)
Loop
With Worksheets("5-9-12")
.Range("J:J,L:L,N:N").NumberFormat = "dd/mm/yyyy"
.Columns("A:X").Columns.AutoFit
.Columns("A:X").HorizontalAlignment = xlCenter
End With
End With
Application.ScreenUpdating = True
End Sub
