Parser un fichier OFX - Doublons de clés

**John Mc Evee** · 21/03/2020, 13h27

Bonjour aux forums,

Je me permets de vous solliciter car je souhaite parser un fichier OFX afin de le coller par la suite sur une feuille excel.

Mon problèmes est le suivant : J'ai des balises (clés) en doublons et les collections ou les dictionnaires ne fonctionnent pas. Voir les clés "STMTTRN"

C'était ma première idée !!!

Existe-il un moyen autre que VBA ? Power query par exemple

Sinon j'avais pensé à un tableau mais je n'ai pas d'idée de condition (if ...) pour détecter le passage d'une collection/dictionnaire au tableau.

Voici un exemple d'un fichier OFX :

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
OFXHEADER:100
DATA:OFXSGML
VERSION:102
SECURITY:NONE
ENCODING:USASCII
CHARSET:1252
COMPRESSION:NONE
OLDFILEUID:NONE
NEWFILEUID:NONE
 
<OFX>
<SIGNONMSGSRSV1>
	<SONRS>
		<STATUS>
			<CODE>0
			<SEVERITY>INFO
		</STATUS>
		<DTSERVER>zzzzz
		<LANGUAGE>FRA
	</SONRS>
</SIGNONMSGSRSV1>
<BANKMSGSRSV1>
	<STMTTRNRS>
		<TRNUID>zzzzz
		<STATUS>
			<CODE>0
			<SEVERITY>INFO
		</STATUS>
		<STMTRS>
			<CURDEF>EUR
			<BANKACCTFROM>
				<BANKID>xxxx
				<BRANCHID>xxx
				<ACCTID>xxxxxxx
				<ACCTTYPE>CHECKING
			</BANKACCTFROM>
			<BANKTRANLIST>
				<DTSTART>xxxxx
				<DTEND>xxxx
				<STMTTRN>
					<TRNTYPE>DEBIT
					<DTPOSTED>20191202
					<DTUSER>20191202
					<TRNAMT>-507.30
					<FITID>aaaaa
					<NAME>label 
				</STMTTRN>
				<STMTTRN>
					<TRNTYPE>DEBIT
					<DTPOSTED>20191204
					<DTUSER>20191204
					<TRNAMT>-30.00
					<FITID>aaaaa
					<NAME>label
				</STMTTRN>
			</BANKTRANLIST>
		</STMTRS>
	</STMTTRNRS>
</BANKMSGSRSV1>
</OFX>

Et voici le module que j'ai créé :

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
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
'**************************************************************************************************
' NAME : MOFX (MODULE)
' VERSION : 0.1
' AUTHOR : John Mc Evee
' DESCRIPTION : Processus permettant de parser un fichier OFX et retourne un ensemble de dictionnaire
'
'**************************************************************************************************
 
Option Explicit
 
Private lBuffer As Long
Private sBuffer As String
 
'**************************************************************************************************
' NAME : Start (PROCESS)
' INPUT : None
' OUTPUT : None
'**************************************************************************************************
Public Sub Start()
 
    Dim oOFX      As Dictionary
    Dim SubItem   As Dictionary
    Dim sFilename As String
    Dim sText     As String
 
 
    sFilename = "C:\Users\John\Desktop\OFX test.ofx"
    sText = ReadFile(sFilename)
    Set oOFX = ParseOFX(sText)
 
 
    sText = vbNullString
 
End Sub
 
'**************************************************************************************************
' NAME : ParseOFX (FUNCTION)
' INPUT : sPathFile (string)
' OUTPUT : * sText (String), lBuffer (Long)
'**************************************************************************************************
Private Function ParseOFX(ByVal sText As String, Optional ByRef lBuffer As Long = 1) As Dictionary
 
    Dim OFX  As New Dictionary
    Dim sKey As String
 
    sText = VBA.Replace(VBA.Replace(VBA.Replace(sText, VBA.vbCr, ""), VBA.vbLf, ""), VBA.vbTab, "")
 
    If Compliance(sText) Then
 
        Do
            lBuffer = Skip(sText, lBuffer)
 
            Select Case VBA.Mid$(sText, lBuffer, 1)
 
                Case "/"
 
                    If VBA.Mid$(sText, lBuffer - 1, 1) = "<" Then
 
                        Do
                            lBuffer = lBuffer + 1
                        Loop While VBA.Mid$(sText, lBuffer, 1) = ">"
 
                        Exit Do
 
                    End If
 
                Case "<"
 
                    If VBA.Mid$(sText, lBuffer + 1, 1) = "/" Then
 
                        Do
                            lBuffer = lBuffer + 1
                        Loop While VBA.Mid$(sText, lBuffer, 1) <> ">"
 
                        Exit Do
 
                    Else
 
                        lBuffer = Skip(sText, lBuffer)
                        sKey = AddKey(sText, lBuffer)
 
                        If VBA.Mid$(sText, lBuffer + 1, 1) = "<" Then
                            OFX.Add sKey, ParseOFX(sText, lBuffer)
                        Else
                            OFX.Add sKey, AddItem(sText, lBuffer)
 
                        End If
 
                    End If
 
                Case Else
 
                    lBuffer = lBuffer + 1
 
            End Select
 
            If lBuffer > VBA.Len(sText) Then Exit Do
 
        Loop
 
    End If
 
    Set ParseOFX = OFX
 
End Function
 
'**************************************************************************************************
' NAME : Skip (FUNCTION)
' INPUT : sText (String), lBuffer (long)
' OUTPUT : lBuffer (Long)
'**************************************************************************************************
Private Function Skip(ByRef sText As String, ByRef lBuffer As Long) As Long
 
    If Not VBA.Mid$(sText, lBuffer, 1) = "<" Then
        lBuffer = lBuffer + 1
    ElseIf VBA.Mid$(sText, lBuffer, 1) = vbNullString Then
        lBuffer = lBuffer + 1
    End If
 
    Skip = lBuffer
 
End Function
 
'**************************************************************************************************
' NAME : AddKey (FUNCTION)
' INPUT : sText (String), lBuffer (long)
' OUTPUT : sBuffer (String)
'**************************************************************************************************
Private Function AddKey(ByRef sText As String, ByRef lBuffer As Long) As String
 
    sBuffer = vbNullString
    lBuffer = lBuffer + 1
    Do
 
        sBuffer = sBuffer & VBA.Mid$(sText, lBuffer, 1)
        lBuffer = lBuffer + 1
 
    Loop While VBA.Mid$(sText, lBuffer, 1) <> ">"
 
    AddKey = sBuffer
 
End Function
 
'**************************************************************************************************
' NAME : AddItem(FUNCTION)
' INPUT : sText (String), lBuffer (long)
' OUTPUT : sBuffer(String)
'**************************************************************************************************
Private Function AddItem(ByRef sText As String, ByRef lBuffer As Long) As String
 
    sBuffer = vbNullString
    lBuffer = lBuffer + 1
    Do
 
        sBuffer = sBuffer & VBA.Mid$(sText, lBuffer, 1)
        lBuffer = lBuffer + 1
 
    Loop While VBA.Mid$(sText, lBuffer, 1) <> "<"
 
    AddItem = sBuffer
 
End Function
 
'**************************************************************************************************
' NAME : Compliance (FUNCTION)
' INPUT : sText (String)
' OUTPUT : True/False (Boolean)
'**************************************************************************************************
Private Function Compliance(ByRef sText As String) As Boolean
 
    If VBA.InStr(sText, "<OFX>") <> 0 And VBA.InStr(sText, "</OFX>") <> 0 Then
        Compliance = True
    Else
        Compliance = False
    End If
 
End Function
 
'**************************************************************************************************
' NAME : ReadFile (FUNCTION)
' INPUT : sPathFile (string)
' OUTPUT : ReadFile (string array)
' SOURCE : https://warin.developpez.com/access/fichiers/#LII-B-1
'**************************************************************************************************
Private Function ReadFile(ByVal sPathFile As String) As String
 
    Const FUNCTION_NAME As String = "ReadFile"
 
    On Error GoTo HANDLER_READFILE
 
    Dim lMemory      As Long
    Dim lBuffer      As Long
    Dim sTabBuffer() As String
    Dim sBuffer      As String
    Dim sTemp        As String
 
    lMemory = FreeFile
    lBuffer = 1
 
    Open sPathFile For Input As #lMemory
 
        While Not EOF(lMemory)
 
            If Not lBuffer = 1 Then
                sBuffer = sBuffer & vbNewLine
                Line Input #lMemory, sTemp
            Else
                Line Input #lMemory, sTemp
            End If
 
            sBuffer = sBuffer & sTemp
            lBuffer = lBuffer + 1
 
        Wend
 
    Close (lMemory)
 
    ReadFile = sBuffer
    Exit Function
 
HANDLER_READFILE:
 
    ReadFile = vbNullString
    Err.Clear
 
End Function

Au plaisir d'échanger sur le sujet.

A+
John

**John Mc Evee** · 21/03/2020, 22h04

Bonjour à tous le forum,

Finalement j'ai trouvé une solution à mon problème. J'ai décidé de remplacer les clés par un compteur.

Pour cela j'ai défini, un mot clé et une fonction IsList. L'objectif de cette fonction est de définir si la clé est type de liste. Si c'est le cas alors le processus utilise un compteur au format texte pour les clés.

Le processus ne traite pas le format des valeurs.

Je laisse le code si cela peut servir à quelqu'un :

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
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
'**************************************************************************************************
' NAME : MOFX (MODULE)
'
' VERSION : 0.1
'
' AUTHOR : John Mc Evee
'
' DESCRIPTION : Processus permettant de parser un fichier OFX et retourne un ensemble de collection
'
' DEPENDANCE : Aucune
'
' USING EXEMPLE :
'
' Public Sub Start()
'
'     Dim OFX       As VBA.Collection
'     Dim Items     As VBA.Collection
'     Dim Item      As Variant
'     Dim sPathFile As String
'     Dim sString   As String
'     Dim lRow      As Long
'
'     sPathFile = "chemin d'accès au fichier"
'
'     sString = ReadFile(sPathFile)
'     Set OFX = ParseOFX(sString)
'
'     ' Indiquer l'item que vous souhaitez cibler
'     Set Items = OFX("OFX")("BANKMSGSRSV1")("0")("STMTRS")("BANKTRANLIST")
'
'     'Exemple de boucle pour copier les données sur une feuille excel
'     lRow = 2
'
'     For Each Item In Items
'
'         If VarType(Item) = vbObject Then
'
'             Sheet1.Cells(lRow, 1).Value = Item("TRNTYPE")
'             Sheet1.Cells(lRow, 2).Value = Item("DTPOSTED")
'             Sheet1.Cells(lRow, 3).Value = Item("DTUSER")
'             Sheet1.Cells(lRow, 4).Value = Item("TRNAMT")
'             Sheet1.Cells(lRow, 5).Value = Item("FITID")
'             Sheet1.Cells(lRow, 6).Value = Item("NAME")
'
'             lRow = lRow + 1
'
'         End If
'
'     Next Item
'
' End Sub
'
'**************************************************************************************************
Option Explicit
 
'**************************************************************************************************
' VARIABLES
'**************************************************************************************************
 
' Définir la variable faisant référence aux listes
Private Const sLIST As String = "STMTTRN"
 
Private lBuffer  As Long        ' Compteur de la chaine de texte
 
Private sBuffer  As String      ' Chaine de texte tampon pour les valeurs et les clés
Private sString  As String      ' Chaine de texte du fichier OFX
 
'**************************************************************************************************
' PUBLIC FUNCTIONS
'**************************************************************************************************
 
'**************************************************************************************************
' NAME : ParseOFX (FUNCTION)
' INPUT : sString (String), lBuffer (Long)
' OUTPUT : OFX (Collection)
'**************************************************************************************************
Public Function ParseOFX(ByVal sString As String, Optional ByRef lBuffer As Long = 1) As VBA.Collection
 
    Dim OFX      As New VBA.Collection      ' Objet retourné par la fonction
    Dim sKey     As String                  ' Chaine de texte contenant la clé
    Dim lCounter As Long                    ' Compteur des clés dans les listes
 
    sString = VBA.Replace(VBA.Replace(VBA.Replace(sString, VBA.vbCr, ""), VBA.vbLf, ""), VBA.vbTab, "")
 
    If Compliance(sString) Then
 
        Do
            lBuffer = Skip(sString, lBuffer)
 
            Select Case VBA.Mid$(sString, lBuffer, 1)
 
                Case "<"
 
                    ' Si c'est une fin de balise alors on passe à la
                    ' prochaine balise
                    If VBA.Mid$(sString, lBuffer + 1, 1) = "/" Then
 
                        Do
                            lBuffer = lBuffer + 1
                        Loop While VBA.Mid$(sString, lBuffer, 1) <> ">"
 
                        Exit Do
 
                    Else
 
                        lBuffer = Skip(sString, lBuffer)
                        sKey = AddKey(sString, lBuffer)
 
                        ' Si c'est une liste, les balises (clés) seront identiques et
                        ' cela générera une erreur de l'ajout de la clés
                        ' On modifie la clé par un compteur
                        If IsList(sKey) Then
                            sKey = CStr(lCounter)
                            lCounter = lCounter + 1
                        Else
                            lCounter = 0
                        End If
 
                        ' Si on est dans le cadre d'une imbrication de balise
                        ' alors on renvoi la fonction sinon on ajoute la valeur
                        If VBA.Mid$(sString, lBuffer + 1, 1) = "<" Then
                            OFX.Add ParseOFX(sString, lBuffer), sKey
                        Else
                            OFX.Add AddItem(sString, lBuffer), sKey
                        End If
 
                    End If
 
                Case Else
 
                    lBuffer = lBuffer + 1
 
            End Select
 
        Loop While lBuffer <= VBA.Len(sString)
 
    End If
 
    Set ParseOFX = OFX
 
End Function
 
'**************************************************************************************************
' PRIVATE FUNCTIONS
'**************************************************************************************************
 
'**************************************************************************************************
' NAME : Skip (FUNCTION)
' INPUT : sString (String), lBuffer (long)
' OUTPUT : lBuffer (Long)
'**************************************************************************************************
Private Function Skip(ByRef sString As String, ByRef lBuffer As Long) As Long
 
    Select Case VBA.Mid$(sString, lBuffer, 1)
 
    Case Is <> "<"
 
        lBuffer = lBuffer + 1
 
    Case Is = VBA.vbNullString
 
        lBuffer = lBuffer + 1
 
    Case Is = VBA.vbNewLine
 
        lBuffer = lBuffer + 1
 
    End Select
 
    Skip = lBuffer
 
End Function
 
'**************************************************************************************************
' NAME : AddKey (FUNCTION)
' INPUT : sString (String), lBuffer (long)
' OUTPUT : sBuffer (String)
'**************************************************************************************************
Private Function AddKey(ByRef sString As String, ByRef lBuffer As Long) As String
 
    sBuffer = vbNullString
    lBuffer = lBuffer + 1
    Do
 
        sBuffer = sBuffer & VBA.Mid$(sString, lBuffer, 1)
        lBuffer = lBuffer + 1
 
    Loop While VBA.Mid$(sString, lBuffer, 1) <> ">"
 
    AddKey = sBuffer
 
End Function
 
'**************************************************************************************************
' NAME : AddItem(FUNCTION)
' INPUT : sString (String), lBuffer (long)
' OUTPUT : sBuffer(String)
'**************************************************************************************************
Private Function AddItem(ByRef sString As String, ByRef lBuffer As Long) As String
 
    sBuffer = vbNullString
    lBuffer = lBuffer + 1
 
    Do
 
        sBuffer = sBuffer & VBA.Mid$(sString, lBuffer, 1)
        lBuffer = lBuffer + 1
 
    Loop While VBA.Mid$(sString, lBuffer, 1) <> "<"
 
    AddItem = sBuffer
 
End Function
 
'**************************************************************************************************
' NAME : Compliance (FUNCTION)
' INPUT : sString (String)
' OUTPUT : True/False (Boolean)
'**************************************************************************************************
Private Function Compliance(ByRef sString As String) As Boolean
 
    If VBA.InStr(sString, "<OFX>") <> 0 And VBA.InStr(sString, "</OFX>") <> 0 Then
        Compliance = True
    Else
        Compliance = False
    End If
 
End Function
 
'**************************************************************************************************
' NAME : IsList (FUNCTION)
' INPUT : sKey (String)
' OUTPUT : True/False (Boolean)
'**************************************************************************************************
Private Function IsList(sKey As String) As Boolean
 
    If VBA.InStr(sKey, sLIST, , VBA.vbBinaryCompare) Then
        IsList = True
    Else
        IsList = False
    End If
 
End Function
 
'**************************************************************************************************
' NAME : ReadFile (FUNCTION)
' INPUT : sPathFile (string)
' OUTPUT : ReadFile (string array)
' SOURCE : https://warin.developpez.com/access/fichiers/#LII-B-1
'**************************************************************************************************
Private Function ReadFile(ByVal sPathFile As String) As String
 
    On Error GoTo HANDLER_READFILE
 
    Dim lMemory      As Long
    Dim sTemp        As String
 
    lMemory = VBA.FreeFile
    lBuffer = 1
 
    Open sPathFile For Input As #lMemory
 
        While Not EOF(lMemory)
 
            If Not lBuffer = 1 Then
                sBuffer = sBuffer & vbNewLine
                Line Input #lMemory, sTemp
            Else
                Line Input #lMemory, sTemp
            End If
 
            sBuffer = sBuffer & sTemp
            lBuffer = lBuffer + 1
 
        Wend
 
    Close (lMemory)
 
    ReadFile = sBuffer
    Exit Function
 
HANDLER_READFILE:
 
    ReadFile = vbNullString
    Err.Clear
 
End Function

Voici le résultat obtenu en sortie avec les données OFX du précédent poste.

Nom : Resultat.PNG
Affichages : 620
Taille : 7,1 Ko

Merci et A+

John

Parser un fichier OFX - Doublons de clés [XL-365]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager