Optimisation code enregistrer facture

baal28

27 Mai 2009 19:46:49

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

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

Autres pages sur : optimisation code enregistrer facture

| Etre averti des réponses
| Alerter

Répondre à baal28

zeb

Expert Programmation

28 Mai 2009 14:10:49

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.

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 :

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 :

Si Ok Alors
  Partie 1...
Sinon
  Exit!
Fin Si
Partie 2...

Mis comme cela :

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

SheetsInNewWorkbook = 1
Workbooks.Add

Autre version, encore plus simple :

Workbooks.Add xlWBATWorksheet

re-

Ligne 39. C'est pas mal, c'est même astucieux. Je te propose ce code pour étude :

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

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]

.

' // 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 !

| Alerter

Répondre à zeb

baal28

28 Mai 2009 23:48:02

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

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

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

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

| Alerter

Répondre à baal28

baal28

28 Mai 2009 23:54:40

Petite note en passant ceci n'est pas bon

SheetsInNewWorkbook = 1

il faut absolument passer par application car s'en est une

Application.SheetsInNewWorkbook = 1

| Alerter

Répondre à baal28

baal28

29 Mai 2009 15:27:08

Et voila ... Est ce que ca plus d'allure comme ca ?

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

| Alerter

Répondre à baal28