Optimisation traitement vba

Version imprimable

Bonjour :

Je souhaite optimiser au maximum le temps du traitement (actuellement presque 20 secondes) de code :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
 
  base = Sheets("Menu").Range("BA20").Value
        Workbooks.Open base
 
        Windows("suivi.xlsm").Activate
        Sheets("extraction").Select
 
 
Windows("Commentaires.xlsx").Activate
 
DoEvents
 
With Sheets("comments")
        dern = .Range("A65536").End(xlUp).row
        Set plage = .Range(Cells(2, 1), Cells(dern, 1))
 
For Each cell In plage
 
    commentaire = cell.Offset(0, 2).Value
    acteur = cell.Offset(0, 3).Value
    date_de_fin = cell.Offset(0, 4).Value
 
        Select Case commentaire
        Case Is <> ""
            ref = cell.Value
            With Workbooks("suivi.xlsm").Sheets("extraction")
            Set C = .Range("A:A").Find(ref, LookIn:=xlValues)
                If Not C Is Nothing Then
                C.Offset(0, 91).Value = commentaire
                C.Offset(0, 92).Value = acteur
                C.Offset(0, 93).Value = date_de_fin
                End If
            End With
        End Select
 
Next cell
End With
 
 Workbooks("Commentaires.xlsx").Activate
 ActiveWorkbook.Close
 
         Windows("suivi.xlsm").Activate
        Sheets("extraction").Select
 
 
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

Merci pour votre aide

27/09/2013, 16h53
EngueEngue

Premièrement:

Application.screenupdating=false

Deuxièmement: au lieu d'utiliser des ranges: mets tes ranges dans des tableaux.. Tu construis donc trois tableaux:
commentaire()
acteur()
date_de_fin()

Une affectation pour toute tes lignes.

Puis après en bouclant sur ton tableau commentaire de ubound à ubound.
Tu mets un if commentaire =""

Et tu remplis un quatrième tableau à trois dimensions

Puis tu le mets dans le range.

Tu devrais bien gagner 10 secondes
27/09/2013, 16h55
ninette24

Application.screenupdating = false est inclus

Par contre je sais pas du tout comment monter ce tableau

Code:

1
2
Dim commentaire()
commentaire = Sheets("comments").Range("C2:C" & dern).Value

27/09/2013, 17h07
EngueEngue

Il n'y a qu'en pataugeant qu'on apprend. Je ne te rendrais aucun service en te filant un code tout craché. Si tu as été capable de pondre ce code tu peux très bien le faire en passant par des tableaux et ça t'apprendra à faire des codes qui iront plus vite :)

Si tu n'y es pas parvenu lundi et que tu montres avoir essayé je t'aiderai!

Bon WE!

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
 
'ouverture du fichier sur le serveur
        base = Sheets("Menu").Range("BA20").Value
        Workbooks.Open base
 
        Windows("suivi.xlsm").Activate
        Sheets("extraction").Select
 
 
Windows("Commentaires.xlsx").Activate
 
DoEvents
 
With Sheets("comments")
        dern = .Range("A65536").End(xlUp).row
 
     commentaire = .Range("C2:C" & dern).Value
     acteur = .Range("D2:D" & dern).Value
     date_de_fin = .Range("E2:E" & dern).Value
      ref = .Range("A2:A" & dern).Value
 
    l = Range("A2:A" & [A65000].End(xlUp).row)
 
        For i = LBound(l) + 1 To UBound(l)
        Select Case commentaire
        Case Is <> ""
            With Workbooks("suivi.xlsm").Sheets("extraction")
            Set C = .Range("A:A").Find(ref, LookIn:=xlValues)
                If Not C Is Nothing Then
                C.Offset(0, 91).Value = commentaire
                C.Offset(0, 92).Value = acteur
                C.Offset(0, 93).Value = date_de_fin
                End If
            End With
        End Select
    Next i
 
End With
 
 Workbooks("Commentaires.xlsx").Activate
 ActiveWorkbook.Close
 
         Windows("suivi.xlsm").Activate
        Sheets("extraction").Select
 
'Application.ScreenUpdating = True
'Application.Calculation = xlCalculationAutomatic

J'ai essayé ta solution, mais il me renvoi une erreur.
Je pense qu'il ya un souci

J'ai réussi à monter le tableau

Cependant j'ai toujours plus de 20 secondes de traitement.....:(

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
With Sheets("comments")
        dern = .Range("A65536").End(xlUp).row
 
    Arr_commentaire = Range("A2:E" & dern)
 
    For R = 1 To UBound(Arr_commentaire, 1) ' First array dimension is rows.
    Select Case Arr_commentaire(R, 3)
    Case Is <> ""
            With Workbooks("suivi.xlsm").Sheets("extraction")
            Set C = .Range("A:A").Find(Arr_commentaire(R, 1), LookIn:=xlValues)
                If Not C Is Nothing Then
                C.Offset(0, 91).Value = Arr_commentaire(R, 3)
                C.Offset(0, 92).Value = Arr_commentaire(R, 4)
                C.Offset(0, 93).Value = Arr_commentaire(R, 5)
                End If
            End With
        End Select
    Next R
 
End With

27/09/2013, 18h26
patricktoulon

heu

Bonjour

sa dure encore 20 ... parceque tu a fait le travail a moitié

tes comment tu les prend dans un tableau que tu crée avec le 1 er classeur
pourquoi ne cré tu pas un 2 eme tableau plutot que de boucle dans le 2 eme classeur :aie::aie::aie::mouarf:
ensuite tu instruit 1 3 eme tableau que tu collera directement dans le sheet avec application transpose

;)
27/09/2013, 19h14
Didier Gonard

Bonjour,

Au niveaux compréhension des Array, tu peux consulter les tutos de DVP ;)

IX. Optimisation du code avec les variables tableau sous Excel

Il y a un exemple ou l'on passe de 1h17mn à 1mn41 secondes sur un traitement de 14 millions de cellules... et un lien vers un autre tuto pour savoir utiliser les instructions relatives aux tableaux.

cordialement,

Didier

Bonjour,

J'ai essayé cette solution, mais je elle ne renvoi pas le résultat de la recherche V

quelquun peux m'aider? Merci

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
 With Sheets("comments")
        dern = .Range("A65536").End(xlUp).row
 
    Arr_commentaire = Range("A2:E" & dern)
 
    dern1 = Workbooks("suivi.xlsm").Sheets("extraction").Range("A65536").End(xlUp).row
 
    Arr_comment = Workbooks("suivi.xlsm").Sheets("extraction").Range("A2:CP" & dern1)
 
    For r = 1 To UBound(Arr_commentaire, 1) ' First array dimension is rows.
    Select Case Arr_commentaire(r, 3)
    Case Is <> ""
 
    For rr = 1 To UBound(Arr_comment, 1)
    If Arr_comment(rr, 1) = Arr_commentaire(r, 1) Then
 
                Arr_comment(rr, 92) = Arr_commentaire(r, 3)
                Arr_comment(rr, 93) = Arr_commentaire(r, 4)
                Arr_comment(rr, 94) = Arr_commentaire(r, 5)
 
    End If
    Next rr
    End Select
    Next r
 
End With

Bonjour à tou(te)s, ninette24,
Sans avoir étudier ton code (et surtout le dimensionnement de tes tableaux),
Insères au moins le résultat du tableau "Arr_comment" dans un Range
Quelque chose comme ça (à l'aveugle)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub TTT()
Dim Arr_commentaire, dern As Long, r As Long, rr As Long
With Sheets("comments")
  dern = .Range("A" & .Rows.Count).End(xlUp).Row
  Arr_commentaire = .Range("A2:E" & dern)
End With
With Workbooks("suivi.xlsm").Sheets("extraction")
  dern = .Range("A" & .Rows.Count).End(xlUp).Row
  Arr_comment = .Range("A2:CP" & dern)
  For r = 1 To UBound(Arr_commentaire, 1)
    If Arr_commentaire(r, 3) <> "" Then
      For rr = 1 To UBound(Arr_comment, 1)
        If Arr_comment(rr, 1) = Arr_commentaire(r, 1) Then
          Arr_comment(rr, 92) = Arr_commentaire(r, 3)
          Arr_comment(rr, 93) = Arr_commentaire(r, 4)
          Arr_comment(rr, 94) = Arr_commentaire(r, 5)
        End If
      Next rr
    End If
  Next r
  .Range("A2").Resize(UBound(Arr_comment, 1), UBound(Arr_comment, 2)) = Arr_comment
End With
End Sub

30/09/2013, 11h13
ninette24

Bonjour,

J4ai essayé la solution mais çà ne fonctionne pas.
Pouvez vous me donner des orientations? un bout de code?

Votre aide me sera précieuse.

Merci
30/09/2013, 11h16
casefayere

Je ne peux pas donner de conseils à l'aveuglette (sans base), envoies un fichier bidon
30/09/2013, 12h11
ninette24

2 pièce(s) jointe(s)

Bonjour,

J'ai mis les deux fichier en pj.

Merci

J'ai testé plusieurs solutions, mais j'avoue que je peine à trouver...

çà plante à nouveau!!!

Merci pour votre aide

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
With Sheets("comments")
        dern = .Range("A65536").End(xlUp).row
 
    Arr_commentaire = Range("A2:E" & dern)
 Arr_commentaire_as = Range("A2:A" & dern)
   ' For r = 1 To UBound(Arr_commentaire, 1) ' First array dimension is rows.
 
     For r = LBound(Arr_commentaire_as) To UBound(Arr_commentaire_as)
    Select Case Arr_commentaire(r, 3)
    Case Is <> ""
 
   ' If Join(Arr_comment, "") = Join(Arr_commentaire, "") Then
 
  '  If Join(Arr_comment, "|") = Join(Arr_commentaire, "|") Then
 
 
  'For i = LBound(Arr_commentaire) To UBound(Arr_commentaire)
        If Arr_commentaire_as(r) = Arr_comment_as(r) Then
 
                Arr_comment(rr, 92) = Arr_commentaire(r, 3)
                Arr_comment(rr, 93) = Arr_commentaire(r, 4)
                Arr_comment(rr, 94) = Arr_commentaire(r, 5)
 
    End If
   ' Next i
    End Select
    Next r
 
End With

1 pièce(s) jointe(s)

Quelques pistes

1. Passer par un tableau est effectivement une solution

2. Il y en a plusieurs qui valent leur pesant de secondes de traitmenent (rapport 4 à 7 selon cas)

2a: Passer par des ranges puis copy du range
2b: encore mieux, passer par des filtres (autofitler par exemple), et joujer sur le specialcell pour ne récupérer que les cellules visibles (xlCellTypeVisible)
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 Function rng_value(myRng As Range, Optional Nbr As Boolean = True) As Range '============================================================================= ' Extract form an input range the numbers by default, or the formulas Funcname = "rng_value" On Error GoTo Errnotexist If Nbr = True Then Set rng_value = myRng.SpecialCells(xlCellTypeConstants, xlNumbers) Else: Set rng_value = myRng.SpecialCells(xlCellTypeFormulas) Debug.Print myRng.Address, rng_value.Address End If Errnotexist: If Err.Number <> 0 Then Debug.Print Err.Number, Err.Description Set rng_value = Nothing Err.Clear End End If End Function
Voir support joint, avec quelques pistes de code (module 6/7)