Optimisation code enregistrer facture

  • Auteur de la discussion baal28
  • Date de début
B

baal28

Nouveau membre
Arff je vais m'en remettre au judicieux conseil de zeb dans le domaine de l'optimisation de code.

Cette macro fonctionne en 3 partie:

1. Première partie vérifie si la facture est complète et inscrit quelques donne sur une page du classeur.

2. Deuxième partie crée un classeur dont la nomenclature est année-mois (09-05) et d'y copier le contenu de la facture sans formule, en respectant le format des cellule et le logo de cie

3. Troisième partie prise en charge de l'inventaire. Ajoute les produits désinstaller et défectueux en stock en indiquant leur état et leur provenance. Si la pièces est doa elle change le statut de cette pièces dans le listing de produits. Si la pièces est installer elle l'enlève de l'inventaire. Et finalement, incrémente de 1 le service utilisé dans l'optique de statistique future.

Bref partie 1 et 2 fonctionnent a merveille, quoique j'imagine y'a mieux. Mais c'est la meilleur optimisation que je puisse faire pour l'instant.

La partie 3 fonctionne, mais j'ai tellement l'impression que c'est plein d'erreur potentiel lors d'utilisation intensive. J'en ai baver toute la journée avec de multiple test. J'arrive pas faire mieux :(
Code: 
Sub Enregistrer()
Dim numerofacture As String, cel As Range, fname As String
Dim Doa As Range
Dim doa2 As Range
Dim Bad As Range
Dim deinstall As Range
Dim qty As Range
Dim install As Range
Dim wb_f As Workbook
Dim ws_f As Worksheet, ws_fs As Worksheet, ws_p As Worksheet, ws_se As Worksheet

Set ws_se = Worksheets("services")
Set ws_p = Worksheets("produits")
Set wb_f = Workbooks("Facturation")
Set ws_f = Worksheets("facture")
Set ws_fs = Worksheets("factures")
numerofacture = ws_f.Range("B10")
abrege = Right(Left(numerofacture, 6), 5)
fname = "F:\ProActive\Factures\" & abrege
last_row = ws_p.Cells(2, 2).End(xlDown).Row

If ws_f.Range("I43") <> 0 And ws_f.Range("C49") <> "" And ws_f.Range("E13") <> "" And ws_f.Range("F13") <> "" And ws_f.Range("H8") <> "" And ws_f.Range("H9") <> "" And ws_f.Range("H10") <> "" Then
  ws_fs.Range("A2").EntireRow.Insert
  ws_fs.Range("A2") = ws_f.Range("B10")
  ws_fs.Range("B2") = ws_f.Range("F1")
  ws_fs.Range("C2") = ws_f.Range("I43")
  ws_fs.Range("D2") = ws_f.Range("H10")
  ws_fs.Range("E2") = ws_f.Range("H8")
  ws_fs.Range("F2") = ws_f.Range("H9")
  ws_fs.Range("G2") = (Now)
  ws_fs.Range("H2") = ws_f.Range("C49")
  ws_fs.Range("I2") = "NON"
Else
  MsgBox ("Facture incomplète")
  Exit Sub
End If

If Dir(fname & ".xls") = "" Then
  Workbooks.Add.SaveAs Filename:=fname
  Workbooks(abrege).Worksheets("Feuil1").Name = numerofacture
  Application.DisplayAlerts = False
  Workbooks(abrege).Worksheets("Feuil2").Delete
  Workbooks(abrege).Worksheets("Feuil3").Delete
  Application.DisplayAlerts = True
Else:
  Workbooks.Open Filename:=fname & ".xls"
  Workbooks(abrege).Worksheets.Add.Name = numerofacture
End If
wb_f.Activate
ws_f.Range("A1:I52").Copy
Workbooks(abrege).Worksheets(numerofacture).Activate
Range("a1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wb_f.Activate
ws_f.Shapes("Image 40").Copy
Workbooks(abrege).Worksheets(numerofacture).Paste
wb_f.Activate
ws_f.Range("A1:I52").Copy
Workbooks(abrege).Worksheets(numerofacture).Activate
Range("a1").Select
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
With Workbooks(abrege).Worksheets(numerofacture).PageSetup
  .PrintArea = Range("a1:i43")
  .LeftMargin = Application.InchesToPoints(0.2)
  .RightMargin = Application.InchesToPoints(0.2)
End With
Workbooks(abrege).Save
Workbooks(abrege).Close

With ws_f.Range("a35:a40")
Set doa2 = .Find(what:="doa", LookIn:=xlValues)
Set Bad = .Find(what:="bad", LookIn:=xlValues)
Set deinstall = .Find(what:="deinstall", LookIn:=xlValues)
  If Not doa2 Is Nothing Then
    With ws_p.Range("C2:c" & last_row)
    Set Doa = .Find(doa2.Offset(0, 2).Value, LookIn:=xlValues)
      If Not Doa Is Nothing Then Doa.Offset(0, -1) = "Doa"
    End With
  End If
  If Not Bad Is Nothing Then
    ws_p.Range("A2").EntireRow.Insert
    ws_p.Range("A2") = "01SSIISEP03"
    ws_p.Range("B2") = "Bad"
    ws_p.Range("C2") = Bad.Offset(0, 2)
    ws_p.Range("D2") = Bad.Offset(0, 1)
    ws_p.Range("E2") = ws_f.Range("B10")
    ws_p.Range("F2") = ws_f.Range("H10")
    ws_p.Range("G2") = ws_f.Range("H8")
  End If
  If Not deinstall Is Nothing Then
    ws_p.Range("A2").EntireRow.Insert
    ws_p.Range("A2") = "01SSIISEP03"
    ws_p.Range("B2") = "Deinstall"
    ws_p.Range("C2") = Bad.Offset(0, 2)
    ws_p.Range("D2") = Bad.Offset(0, 1)
    ws_p.Range("E2") = ws_f.Range("B10")
    ws_p.Range("F2") = ws_f.Range("H10")
    ws_p.Range("G2") = ws_f.Range("H8")
  End If
End With
For Each cel In ws_f.Range("h35:h40")
  If cel <> "" Then
    With ws_p.Range("C2:c" & last_row)
    Set install = .Find(cel.Value, LookIn:=xlValues)
      If Not install Is Nothing Then
      install.EntireRow.Delete
      End If
    End With
  End If
Next cel
For Each cel In ws_f.Range("E13:E28")
  If cel <> "" Then
    With ws_se.Range("A2:A65536")
    Set qty = .Find(cel.Value, LookIn:=xlValues)
      If Not qty Is Nothing Then
      qty.Offset(0, 5) = qty.Offset(0, 5) + cel.Offset(0, 1)
      End If
    End With
  End If
Next cel
End Sub
 
zeb

zeb

Modérateur
C'est pas mal du tout. J'ai même peine à croire que ce bout de code soit d'un si prétendu débutant.
En plus de l'optimisation, il reste quelques petites erreurs.

Audit de code

■ Lignes 12, 13, 15, 16. Lorque plusieurs classeurs sont utilisés, il est prudent de préciser le classeur.
Code: 
Set ws_se = ThisWorkbook.Worksheets("services" )
Set ws_se = Workbooks("classeur").Worksheets("services" )

■ Lignes 30, 34. Pourquoi ces parenthèses ? Ne pas confondre Function et Sub.

■ Ligne 34. Le programme va s'arrêter. Par convention, il faut prévenir l'utilisateur par l'utilisation d'une icône dans la boîte de dialogue. (i) pour information, /!\ pour avertissement, [X] pour arrêt. Donc :
Code: 
MsgBox "Facture incomplète", vbCritical

■ Ligne 22 à 26. Personnellement, j'use et j'abuse des "Exit" (exit en shell, return en C/C++, etc.) J'organisue donc mon code non pas comme cela :
Code: 
Si Ok Alors
  Partie 1...
Sinon
  Exit!
Fin Si
Partie 2...
Mis comme cela :
Code: 
Si Pas Ok Alors
  Exit!
Fin Si
Parties 1 & 2.
C'est plus lisible, on voit et on traite bien les cas particuliers d'abord, puis on traite d'un coup le reste du traitement, sans plus se poser de question.

■ Lignes 41 à 44. C'est pas bien, c'est nul, c'est mal ! Encore faut-il savoir comment faire autrement ;)
Code: 
SheetsInNewWorkbook = 1
Workbooks.Add
:sol: Autre version, encore plus simple :
Code: 
Workbooks.Add xlWBATWorksheet
re- :sol:

■ Ligne 39. C'est pas mal, c'est même astucieux. Je te propose ce code pour étude :
Code: 
Dim wb_a As Workbook
Dim ws_a As Worksheet

If Dir(fname & ".xls" ) = "" Then
	SheetsInNewWorkbook = 1
	Set wb_a = Workbooks.Add
	Set ws_a = wb_a.Worksheets(1)
	ws_a.Name = numerofacture
	wb_a.SaveAs Filename:=fname
	wb_a.Add.Close False
Je n'aime pas me fier au nom du classeur. C'est trop alléatoire. Surtout que Excel donne des noms différents selon les cas, par exemple avant et après enregistrement. De la même façon, je n'utilise pas le nom des feuilles. Le jour où ta macro est exécutée sur un XL en anglais, la feuille 1 ne s'appelle plus Feuil1 mais Sheet1. Trop de fois j'ai vu des programmes planter comme ça :o

■ Lignes 49, 51, 54, 57, 59. NON, NON, NON, NON et NON. [:marcus67]
____________________________________________________________

Pas de ActiveTruc/Selection.Machin. Pourquoi activer ces objets ?
Les laisser là où ils sont et utiliser leurs propriétés et méthodes !

Ligne 49, activate inutile, puisque ligne 50, on précise sur quelle feuille on travaille.

Ligne 51, activate utile puisque ligne 52, on a oublié de préciser sur quelle feuille on travaile. Evidemment, corriger les lignes 51 ET 52.

Remplacer chaque Truc.Activate/ActiveTruc.Machin ou Truc.Select/Selection.Machin par Truc.Machin[:b].
Code: 
' // MAL
Range("a1").Select
Selection.PasteSpecial Paste:=xlValues
' // Bien
Range("A1").PasteSpecial Paste:=xlValues
____________________________________________________________

■ Lignes 67, 68. Bien, très bien. Parce que je suis paranoïaque, j'ajoute toujours False à Close. On ne sait jamais, Excel peut vouloir changer quelque chose avant qu'on ne ferme. Or si j'ai enregistré avant, c'est que je ne veux pas que l'utilisateur mette son grain de sel !

■ Lignes 62 à 66. Bonne utilisation de With.
■ Lignes 75 à 78, 103 à 108, 113 à 118. Mauvaise utilisation de With : imbrication + tout ça pour une seule ligne :pfff:

■ Ligne 106. [:alzheimer parkinson] Mais puisque je t'ai déjà expliqué qu'il faut aller à rebours pour supprimer des lignes, bon sang !
 
B

baal28

Nouveau membre
1 ere et 2 ieme partie en très bonne voie

Code: 
Set wb_f = ThisWorkbook
Set ws_se = ThisWorkbook.Worksheets("services")
Set ws_p = ThisWorkbook.Worksheets("produits")
Set ws_f = ThisWorkbook.Worksheets("facture")
Set ws_fs = ThisWorkbook.Worksheets("factures")
numerofacture = ws_f.Range("B10")
abrege = Right(Left(numerofacture, 6), 5)
fname = "F:\ProActive\Factures\" & abrege
last_row = ws_p.Cells(2, 2).End(xlDown).Row

If ws_f.Range("I43") = 0 Or ws_f.Range("C49") = "" Or ws_f.Range("E13") = "" Or ws_f.Range("F13") = "" Or ws_f.Range("H8") = "" Or ws_f.Range("H9") = "" Or ws_f.Range("H10") = "" Then
  MsgBox "Facture incomplète", vbCritical
  Exit Sub
End If

ws_fs.Range("A2").EntireRow.Insert
ws_fs.Range("A2") = ws_f.Range("B10")
ws_fs.Range("B2") = ws_f.Range("F1")
ws_fs.Range("C2") = ws_f.Range("I43")
ws_fs.Range("D2") = ws_f.Range("H10")
ws_fs.Range("E2") = ws_f.Range("H8")
ws_fs.Range("F2") = ws_f.Range("H9")
ws_fs.Range("G2") = Now
ws_fs.Range("H2") = ws_f.Range("C49")
ws_fs.Range("I2") = "NON"

If Dir(fname & ".xls") = "" Then
  Application.SheetsInNewWorkbook = 1
  Set wb_a = Workbooks.Add
  Set ws_a = wb_a.Worksheets(1)
  ws_a.Name = numerofacture
  wb_a.SaveAs Filename:=fname
Else:
  Set wb_a = Workbooks.Open(fname & ".xls")
  Set ws_a = wb_a.Worksheets.Add
  ws_a.Name = numerofacture
End If

ws_f.Range("A1:I52").Copy
ws_a.Range("a1").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ws_f.Shapes("Image 40").Copy
ws_a.Paste
ws_f.Range("A1:I52").Copy
ws_a.Range("a1").PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
With wb_a.Worksheets(1).PageSetup
  .PrintArea = Range("a1:i43")
  .LeftMargin = Application.InchesToPoints(0.2)
  .RightMargin = Application.InchesToPoints(0.2)
End With
wb_a.Save
wb_a.Close False

2 petit problème d'optimisation

ligne 41 et 42: d'imbriquer en une seul ligne
Code: 
ws_f.Shapes("Image 40").Copy
ws_a.Paste

ligne 45 à 49: Je comprends pas pourquoi quand je mets With ws_a.PageSetup ca me donne une erreur
Code: 
With wb_a.Worksheets(1).PageSetup
  .PrintArea = Range("a1:i43")
  .LeftMargin = Application.InchesToPoints(0.2)
  .RightMargin = Application.InchesToPoints(0.2)
End With

Pour la 3 ieme partie je suis encore dessus... ne me souffler pas la réponse toute faite pour la 3 ieme parti. Je soumettrai la 3 ieme partie optimiser aussitôt terminer
 
B

baal28

Nouveau membre
Petite note en passant ceci n'est pas bon
Code: 
SheetsInNewWorkbook = 1
il faut absolument passer par application car s'en est une
Code: 
Application.SheetsInNewWorkbook = 1
 
B

baal28

Nouveau membre
Et voila ... Est ce que ca plus d'allure comme ca ?
Code: 
Sub Enregistrer()
Dim numerofacture As String, fname As String
Dim Doa As Range, qty As Range, cel As Range
Dim r As Long
Dim wb_f As Workbook, wb_a As Workbook
Dim ws_f As Worksheet, ws_fs As Worksheet, ws_p As Worksheet, ws_se As Worksheet, ws_a As Worksheet
Set wb_f = ThisWorkbook
Set ws_se = ThisWorkbook.Worksheets("services")
Set ws_p = ThisWorkbook.Worksheets("produits")
Set ws_f = ThisWorkbook.Worksheets("facture")
Set ws_fs = ThisWorkbook.Worksheets("factures")
numerofacture = ws_f.Range("B10")
abrege = Right(Left(numerofacture, 6), 5)
fname = "F:\ProActive\Factures\" & abrege
last_row = ws_p.Cells(2, 2).End(xlDown).Row
If ws_f.Range("I43") = 0 Or ws_f.Range("C49") = "" Or ws_f.Range("E13") = "" Or ws_f.Range("F13") = "" Or ws_f.Range("H8") = "" Or ws_f.Range("H9") = "" Or ws_f.Range("H10") = "" Then
  MsgBox "Facture incomplète", vbCritical
  Exit Sub
End If
ws_fs.Range("A2").EntireRow.Insert
ws_fs.Range("A2") = ws_f.Range("B10")
ws_fs.Range("B2") = ws_f.Range("F1")
ws_fs.Range("C2") = ws_f.Range("I43")
ws_fs.Range("D2") = ws_f.Range("H10")
ws_fs.Range("E2") = ws_f.Range("H8")
ws_fs.Range("F2") = ws_f.Range("H9")
ws_fs.Range("G2") = Now
ws_fs.Range("H2") = ws_f.Range("C49")
ws_fs.Range("I2") = "NON"
If Dir(fname & ".xls") = "" Then
  Application.SheetsInNewWorkbook = 1
  Set wb_a = Workbooks.Add
  Set ws_a = wb_a.Worksheets(1)
  ws_a.Name = numerofacture
  wb_a.SaveAs Filename:=fname
Else:
  Set wb_a = Workbooks.Open(fname & ".xls")
  Set ws_a = wb_a.Worksheets.Add
  ws_a.Name = numerofacture
End If
ws_f.Range("A1:I52").Copy
ws_a.Range("a1").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ws_f.Shapes("Image 40").Copy
ws_a.Paste
ws_f.Range("A1:I52").Copy
ws_a.Range("a1").PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
With wb_a.Worksheets(1).PageSetup
  .PrintArea = Range("a1:i43")
  .LeftMargin = Application.InchesToPoints(0.2)
  .RightMargin = Application.InchesToPoints(0.2)
End With
wb_a.Save
wb_a.Close False
For Each cel In ws_f.Range("A35:A40")
  If LCase(cel.Value) = "bad" Or UCase(cel.Value) = "DEINSTALL" Then
    ws_p.Range("A2").EntireRow.Insert
    ws_p.Range("A2") = "01SSIISEP03"
    ws_p.Range("B2") = cel
    ws_p.Range("C2") = cel.Offset(0, 2)
    ws_p.Range("D2") = cel.Offset(0, 1)
    ws_p.Range("E2") = ws_f.Range("B10")
    ws_p.Range("F2") = ws_f.Range("H10")
    ws_p.Range("G2") = ws_f.Range("H8")
  End If
  If LCase(cel.Value) = "doa" Then
    Set Doa = ws_p.Columns(3).Cells.Find(what:=cel.Offset(0, 2))
    Doa.Offset(0, -1) = cel
    Doa.Offset(0, 2) = ws_f.Range("B10")
    Doa.Offset(0, 3) = ws_f.Range("H10")
    Doa.Offset(0, 4) = ws_f.Range("H8")
  End If
Next
For Each cel In ws_f.Range("H35:H40")
  If cel <> "" Then
    For r = last_row To 2 Step -1
      If ws_p.Cells(r, 3).Value = cel.Value Then
        ws_p.Cells(r, 1).EntireRow.Delete
      End If
    Next
  End If
Next
For Each cel In ws_f.Range("E13:E28")
  If cel <> "" Then
    Set qty = ws_se.Columns(1).Cells.Find(what:=cel)
    qty.Offset(0, 5) = qty.Offset(0, 5) + cel.Offset(0, 1)
  End If
Next
End Sub
 
Vous devez vous inscrire ou vous connecter pour répondre ici.
Dernières actus
Derniers messages publiés
Statistiques globales
Discussions
730 128
Messages
6 717 834
Membres
1 586 369
Dernier membre
Mouslah
Partager cette page
Haut