Améliorer une macro VB

**shadelv** · 05/09/2013, 12h42

Bonjour,

J'ai réalisé une macro Excel pas très performante et je me demandais si vous pouviez m'aider à l'améliorer.
A partir d'un feuille de choix de structures, la macro récupère un fichier en binaire ebcdic pour créer un classeur avec des données lisibles par lignes selon un format de conversion donnée par donnée.
Elle prend 15 secondes pour traiter un fichier binaire de 7 Mo (~2000 lignes) mais peut être amenée à traiter des millions de lignes.
Dans le code suivant, quelles sont les parties les plus gourmandes en ressources et comment reformuler ?
La première partie, avant le "open", est une initialisation des zones et des feuilles de travail. La deuxième partie est la boucle de traitement à proprement parler.

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
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
    maxSeg = 30
    maxStruct = 15
    Set wbChoix = ActiveWorkbook
    Set wsChoix = Sheets("choix")
    wsChoix.Select
 
    recLen = [A2]
 
    Set structs = Range([D1], [D1].End(xlToRight))
    Set conds = Range([D2], [D2].End(xlToRight))
    Set vals = Range([D3], [D3].End(xlToRight))
    Set tmp = Range([D4], [D4].End(xlToRight))
    nbStruct = structs.Count
    If tmp.Count <> nbStruct Or conds.Count <> nbStruct Or vals.Count <> nbStruct Then
        Exit Sub
    End If
 
    filePath = Application.GetOpenFilename
    If filePath = False Then
        Exit Sub
    End If
 
    ReDim wsStruct(nbStruct - 1) As Worksheet
    ReDim condPos(nbStruct - 1) As Long
    ReDim condLen(nbStruct - 1) As Long
    ReDim condUti(nbStruct - 1) As String
    ReDim outRow(nbStruct - 1) As Long
    ReDim structLen(nbStruct - 1) As Long
 
    Dim convD(255) As String, conv3(255) As String
    Sheets("ebcdic").Activate
    For i = 0 To 255
        convD(i) = Cells(i + 1, 4)
        conv3(i) = Cells(i + 1, 2)
    Next i
 
    Workbooks.Add
    Set wbNew = ActiveWorkbook
    For i = 0 To nbStruct - 1
        Sheets.Add
        Set wsStruct(i) = ActiveSheet
        ActiveSheet.Name = structs(i + 1)
    Next i
 
    minRead = 1
    For i = 0 To nbStruct - 1
        col = i + [D4].Column
        row = [D4].row
        wbChoix.Activate
        wsChoix.Select
        Sheets(Cells(row, col).Value).Select
        For Each cell In Range([D2], [D2].End(xlDown))
            If cell = conds(i + 1) Then
                condPos(i) = Cells(cell.row, 9) - 1
                condLen(i) = Cells(cell.row, 8)
                condUti(i) = Cells(cell.row, 7)
                Exit For
            End If
        Next cell
        If condLen(i) = 0 Then
            MsgBox "cond pas trouvée"
            Exit Sub
        End If
        r = condPos(i) + condLen(i)
        If r > minRead Then
            minRead = r
        End If
        Range([O1].End(xlDown), [O1].End(xlToRight)).Copy
        wbNew.Activate
        wsStruct(i).Select
        Cells(1, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        outRow(i) = [A1].End(xlDown).row + 1
    Next i
 
    If recLen = "" Then
        ReDim bytes1(minRead - 1) As Byte
    Else
        ReDim bytes1(recLen - 1) As Byte
    End If
 
    maxLen = 2
    For i = 0 To nbStruct - 1
        col = i + [D4].Column
        For j = 1 To maxSeg - 1
            row = j + [D4].row
            wbChoix.Activate
            wsChoix.Select
            If Cells(row, col) = "" Then
                Exit For
            End If
            Sheets(Cells(row, col).Value).Select
            Range([O1].End(xlDown), [O1].End(xlToRight)).Copy
            wbNew.Activate
            wsStruct(i).Select
            structLen(i) = Cells(1, pasteCol - 1) + Cells(2, pasteCol - 1)
            pasteCol = [A1].End(xlToRight).Column + 1
            Cells(1, pasteCol).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            Cells(1, pasteCol).EntireColumn.Delete
            Cells(1, pasteCol).Select
            nextCol = Selection.End(xlToRight).Column
            Range(Cells(1, pasteCol), Cells(1, nextCol)).Select
            For Each cell In Selection
                cell.Value = cell.Value + structLen(i)
            Next cell
        Next j
    Next i
 
    wbNew.Activate
    For i = 0 To nbStruct - 1
        wsStruct(i).Select
        Cells.NumberFormat = "@"
        last = [A1].End(xlToRight).Column
        If recLen = "" And Cells(4, last) = "FILLER" Then
            Cells(1, last).EntireColumn.Delete
            last = last - 1
        End If
        structLen(i) = Cells(1, last) + Cells(2, last)
    Next i
 
    wbNew.Activate
    fileId = FreeFile
    Open filePath For Binary Access Read As fileId
 
    While Not EOF(fileId)
        Get fileId, , bytes1
        For i = 0 To nbStruct - 1
            sData = ""
            If condUti(i) = "D" Then
                For j = condPos(i) To condPos(i) + condLen(i) - 1
                    sData = sData & convD(bytes1(j))
                Next j
            Else ' "3"
                For j = condPos(i) To condPos(i) + condLen(i) - 1
                    sData = sData & conv3(bytes1(j))
                Next j
            End If
            If sData = vals(i + 1) Then
                Exit For
            End If
        Next i
        If i < nbStruct Then
            wsStruct(i).Select
            If recLen <> "" Then
                For j = 2 To [A1].End(xlToRight).Column
                    sData = ""
                    If Cells(3, j) = "D" Then
                        For k = Cells(1, j) To Cells(1, j) + Cells(2, j) - 1
                            sData = sData & convD(bytes1(k))
                        Next k
                    Else
                        If Cells(3, j) = "3" Then
                            For k = Cells(1, j) To Cells(1, j) + Cells(2, j) - 1
                                sData = sData & conv3(bytes1(k))
                            Next k
                        End If
                    End If
                    Cells(outRow(i), j) = sData
                Next j
            Else
                ReDim bytes2(structLen(i) - minRead - 1) As Byte
                Get fileId, , bytes2
                For j = 2 To [A1].End(xlToRight).Column
                    sData = ""
                    If Cells(3, j) = "D" Then
                        For k = Cells(1, j) To Cells(1, j) + Cells(2, j) - 1
                            If k < minRead Then
                                sData = sData & convD(bytes1(k))
                            Else
                                sData = sData & convD(bytes2(k - minRead))
                            End If
                        Next k
                    Else
                        If Cells(3, j) = "3" Then
                            If k < minRead Then
                                sData = sData & conv3(bytes1(k))
                            Else
                                sData = sData & conv3(bytes2(k - minRead))
                            End If
                        End If
                    End If
                    Cells(outRow(i), j) = sData
                Next j
            End If
            outRow(i) = outRow(i) + 1
        End If
    Wend

Merci d'avoir pris la peine de lire.

Invité · 06/09/2013, 13h14

Bonjour,
ton problème c'est que tu lis ton fichier byte à byte donc un accès disque pour chaque lecture.

il faut Bufferiser la totalité de ton fichier pour cela connaitre sa taille en octs.
ensuite utiliser ton Buffer comme si c'était ton fichier 1 accès disque.

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
Sub Test
Dim Buffer() As Byte
L = Taille_Fichier(Fichier)
ReDim Buffer(L)
Open Fichier For Binary As #intFileNumber
While Not EOF(intFileNumber)
Get #intFileNumber, , Buffer
Wend
Close #intFileNumber
For I = 0 To UBound(Buffer)
t = Hex$(Buffer(I))
Next
End Sub
 
'Taille d'un fichier
Function Taille_Fichier(Fichier)
Dim Fso As Object
Dim Fich As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Fich = Fso.GetFile(Fichier)
    Taille_Fichier = Fich.Size
End Function

idem si il faut écrire

Code :

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

1
2
3
4
5
6
7
8
9
10
Dim BuffeurEcritur() As Byte
Dim IBuf As Long
ReDim BuffeurEcritur(1024)
BuffeurEcritur(IBuf) = "ee"
If IBuf = 1024 Then
ecrir BuffeurEcritur
IBuf = -1
ReDim BuffeurEcritur(1024)
End If
IBuf = IBuf + 1

Améliorer une macro VB

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager