Discussion :

[pat91]

Bonjour,

Je vous sollicite pour voir s'il y a moyen d'optimiser le code ci-dessous car le traitement est soit très long (plusieurs minutes) soit plante Excel par saturation de UC (processus sans réponse d’Excel) !

Ce code est l'assemblage de bouts de code généreusement proposé par des contributeurs de ce forum, qui se reconnaitrons et que je remercie encore

J'en ai fait une synthèse et essayé de le simplifier, mais là je pense avoir atteint mes limites.
Pouvez-vous y jeter un coup d’œil pour voir s’il y a possibilité de réduire la charge de l’UC.
Le fichier joint comporte ~380 fichiers de données, mais normalement je récupère 800 fichiers.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
 
Option Explicit
 
Sub Empilement()
    Dim F1 As Worksheet, F2 As Worksheet
    Dim i As Long, DerCol_f1 As Long, DerCol As Long, DerLig_f1 As Long, DerLig_f2 As Long, DerCol_f2 As Long, DerLig_Mes As Long, Lig_f2 As Long, Col_f2 As Long, c As Long, Nb_Lig As Long, k As Long, L As Long
    Dim m As Range, cell As Range
    Dim d As Object
    Application.ScreenUpdating = False
    Set F1 = Sheets("BDD")
    Set F2 = Sheets("Synthese")
    F2.Cells.Clear
 
 
    'Concatenation et positionnement du terme mesure x
 
    DerLig_f1 = F1.Cells(Rows.Count, 1).End(xlUp).Row
        'Application.ScreenUpdating = False
            For i = 1 To DerLig_f1
                If F1.Cells(i, "A") Like "Mesure:" Then
                    F1.Cells(i + 16, "A") = F1.Cells(i, "A") & F1.Cells(i, "B")
                End If
            Next i
 
 
    'sélection et transposition des données de colonnes Feuille 1 à lignes Feuille 2
 
    Set d = CreateObject("Scripting.Dictionary")
    DerLig_f1 = F1.Range("A" & Rows.Count).End(xlUp).Row
    Col_f2 = 2
    For i = 1 To DerLig_f1
        Lig_f2 = 13
         With F1.Range("A1:A" & DerLig_f1)
            Set m = .Find("Mesure:" & i, lookat:=xlWhole)
 
            'identification de la plage de données et enregistrement du NB de colonne
            If Not m Is Nothing Then
                DerCol_f1 = F1.Cells(m.Row + 1, 16384).End(xlToLeft).Column
                DerLig_Mes = F1.Cells(m.Row + 1, "B").End(xlDown).Row
                For c = DerCol_f1 To 1 Step -1
                    For Each cell In Range(F1.Cells(m.Row + 1, c), F1.Cells(DerLig_Mes, c))
                        d.Add cell, ""
                    Next cell
                    F2.Cells(Lig_f2, Col_f2).Resize(d.Count, 1) = Application.Transpose(d.keys)
                     Lig_f2 = Lig_f2 + d.Count
                    d.RemoveAll
                Next c
                F2.Cells(1, Col_f2) = i
                Col_f2 = Col_f2 + 1
            End If
        End With
    Next i
 
    'remplissage de la première colonne avec la position des données par ligne
    With F1.Range("A1:A" & DerLig_f1)
        Set m = .Find("mesure:1", lookat:=xlWhole)
        DerLig_Mes = F1.Cells(m.Row, "B").End(xlDown).Row
        DerCol_f2 = F2.Cells(2, 2).End(xlToRight).Column
        DerLig_f2 = F2.Columns("B").Find(what:="*", searchdirection:=xlPrevious).Row
 
    End With
 
    'récupération des heures de relevées des données
    F2.Cells(2, 1) = "Heure :"
    L = 2
    DerLig_f1 = F1.Cells(Rows.Count, 1).End(xlUp).Row
        'Application.ScreenUpdating = False
            For i = 1 To DerLig_f1
                If F1.Cells(i, "A") Like "Heure:" Then
                    F1.Cells(i, "B").Copy
                    F2.Cells(2, L).PasteSpecial Paste:=xlPasteValues
                    Application.CutCopyMode = False
                    F2.Cells(2, L).NumberFormat = "[$-F400]h:mm:ss AM/PM"
                End If
                If F2.Cells(2, L) <> "" Then L = L + 1
             Next i
 
 
    Set m = Nothing
    Set F1 = Nothing
    Set F2 = Nothing
 
End Sub

Merci par avance.

En PJ le fichier