[AC-2010] Croisé deux fichiers Excel et en créer deux autres [Résolu]

[Serigne-BA]

Bonjour tout le monde !

Je dois créer une petite application Access qui génère des fichiers Excel.
J’ai deux fichiers Excel :

Un fichier « liste des clients à contacter » qu’il faut télécharger tous les jours (à partir d’une autre source) et qui contient les données suivantes : Numéro client, Nom client, Numéro dossier, catégorie, groupe, gestionnaire, tel, pays.
Un autre fichier « annuaire client » qui peut changer si on a un nouveau client et qui contient les données suivantes : Numéro client, Nom client, Numéro dossier, paiement.
Je dois croiser ces deux fichiers et en créer deux autres :
• Un fichier « A » liste des clients à contacter en supprimant tous les clients de Maroc et tous les clients qui vérifient en même temps les conditions suivantes.
o paiement = cash
o pays = France
o catégorie = AFFI
• un autre fichier « B » qui contient seulement les clients supprimés dans le fichier initial.
Le but c’est de ne pas contacter certains clients qui ont déjà fait des options par défaut.
Ma première idée c’est de :
 créer une table annuaire en important le fichier Excel annuaire
 un formulaire pour
o ajouter un client dans l’annuaire,
o importer le fichier liste des clients à contacter et le mettre dans une table temporaire
o un bouton créer et exporter le fichier A
o un bouton créer et exporte le fichier B

Est-ce que vous pensez que c’est la meilleure façon de faire avant que je me lance dessus ?

Merci pour votre aide !

[Serigne-BA]

Salut tout le monde,
j'ai dans mon formulaire une etiquette qui me permet de choisir le chemin de mon fichier excel "liste des clients à contacter" je voudrais ensuite créer automatiquement une table à partir de ce fichier à l'aide d'un simple clic sur un bouton.
Est ce que quelqu'un aurait une idée à me passer ?

[Serigne-BA]

Envoyé par Serigne-BA

Salut tout le monde,
je voudrais ensuite créer automatiquement une table à partir de ce fichier à l'aide d'un simple clic sur un bouton.
Est ce que quelqu'un aurait une idée à me passer ?

Problème résolu maintenant reste à croisé les donnèes des deux tables et en créer deux autres fichiers excel !

Voici le code si ça intéresse quelqu'un !

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
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
' IMPORTER un modèle excel dans la table VEILLE
Public Function ImportExcelVeille(ByVal FileName As String) As Boolean
 
' objets OLE automation EXCEL
Dim appExcel As Excel.Application
Dim wbk As Excel.Workbook, wsht As Excel.Worksheet
 
' Id_veille en cours (la clé primaire de la table), compte nb de lignes insérés, erreurs
Dim id_veille As Long, cptVeille As Long, cptErrors As Long
 
' tableau des noms de champs de la table
Dim EnTeteVeille As Variant
' collection des noms de champs/positions dans excel
Dim colPositionVeilles As New Collection
 
' ligne en cours
Dim Ligne As Long
' diverses variables temporaires
Dim Positions(50) As Long, LigneEncours As Variant, arrTemp As Variant
Dim blnTemp As Boolean, cptSuccessiveLignesVides As Long
Dim i As Long
 
 
On Error GoTo ImportExcelVeille_Error
DoCmd.Hourglass True
SysCmd acSysCmdSetStatus, "Importation..."
 
Set appExcel = New Excel.Application
 
' liste des champs attendus dans la table
EnTeteVeille = GetFields("VEILLE")
 
appExcel.Visible = False
Set wbk = appExcel.Workbooks.Open(FileName, ReadOnly:=True)
Set wsht = wbk.Worksheets(1)
 
 
Do ' boucle sur l'ensemble des lignes
 
    ' récupérer une ligne (non vide) dans le tableau temporaire :
    Ligne = Ligne + 1
    If GetExcelLine(wsht, Ligne, LigneEncours) Then
 
        ' si pas encore fait, d'abord chercher les entêtes de colonne:
        If colPositionVeilles.Count = 0 Then
            ' si pas ou peu de correspondance, effacer la collection
            If Not RetrouverChampsExcel(EnTeteVeille, LigneEncours, colPositionVeilles) _
            Then Set colPositionVeilles = New Collection
 
        'sinon traitement d'une ligne normale
        Else
            ' récupérer les colonnes existantes à insérer sauf PK :
            arrTemp = GenererTableauInsertion(EnTeteVeille, colPositionVeilles, _
                LigneEncours, Array("Id_veille"))
            ' insérer le texte dans la table TEXTES - "Id_veille", Id_veille,
            If FN_INSERT("VEILLE", arrTemp, "Id_veille", id_veille) _
                Then cptVeille = cptVeille + 1 _
                Else cptErrors = cptErrors + 1
 
        End If
 
        cptSuccessiveLignesVides = 0
    Else ' compter les lignes vides successives
        cptSuccessiveLignesVides = cptSuccessiveLignesVides + 1
    End If
 
Loop Until cptSuccessiveLignesVides > 10 ' on quitte après 10 lignes vides
 
ImportExcelVeille = (cptVeille > 0)
 
ImportExcelVeille_Exit:
Set wsht = Nothing
Set wbk = Nothing
appExcel.Quit
Set appExcel = Nothing
 
SysCmd acSysCmdClearStatus
DoCmd.Hourglass False
Exit Function
 
ImportExcelVeille_Error:
 
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Function ImportExcelVeille of Module mdImportExcel", vbCritical
    Resume ImportExcelVeille_Exit
End Function
 
 
 
' récupérer la liste des champs d'une table dans un tableau
Public Function GetFields(ByVal Tablename As String) As Variant
Dim oRS As DAO.Recordset, fld As DAO.Fields
Dim arrTemp() As String, i As Long
 
On Error GoTo GetFields_Error
 
Set oRS = CurrentDb.OpenRecordset(Tablename, dbOpenDynaset, dbSeeChanges)
ReDim arrTemp(oRS.Fields.Count - 1)
For i = 0 To oRS.Fields.Count - 1
    arrTemp(i) = oRS.Fields(i).Name
Next i
GetFields = arrTemp
 
Exit Function
GetFields_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & _
    ") in Function GetFields of Module mdSql", vbCritical
 
End Function
 
 
Public Function ExistKey(ByVal key As String, ByVal col As Collection) As Boolean
Dim item As Variant
On Error GoTo KeyNotExists
    item = col(key)
    ExistKey = True
Exit Function
KeyNotExists:
    ExistKey = False
End Function
 
 
' recherche d'un élément dans un tableau
Public Function look_in_array(Lookup As Variant, in_array As Variant, Optional _
    ByRef Position As Long, Optional OptionBinaryCompare As Boolean = False) As _
    Boolean
Dim i As Long
 
If IsArray(in_array) Then
    For i = LBound(in_array) To UBound(in_array)
        If (OptionBinaryCompare And Lookup = in_array(i)) Or (Not _
            OptionBinaryCompare And Lookup Like in_array(i)) Then
 
            Position = i
            look_in_array = True
            Exit Function
        End If
    Next i
End If
 
End Function
 
 
 
' récupérer une ligne du fichier Excel, compter les cases vides
' ligne considérée vide si moins de 5 cellules non vides.
Private Function GetExcelLine(ByVal sh As Worksheet, ByVal Ligne As Long, ByRef arrLigne As Variant) As Boolean
Dim i As Long, arrTemp() As String, CptEmptyCells As Long, cptSuccessiveEmptyCells As Long
ReDim arrTemp(50)
 
Do
    i = i + 1
    arrTemp(i) = sh.Cells(Ligne, i).Value
    If IsEmpty(sh.Cells(Ligne, i).Value) Then
        CptEmptyCells = CptEmptyCells + 1
        cptSuccessiveEmptyCells = cptSuccessiveEmptyCells + 1
    Else
        cptSuccessiveEmptyCells = 0
    End If
Loop Until cptSuccessiveEmptyCells >= 10 Or i >= 50
ReDim Preserve arrTemp(i - cptSuccessiveEmptyCells)
arrLigne = arrTemp
GetExcelLine = (i - CptEmptyCells > 5)
End Function
 
 
' générer le tableau des champs à insérer
Private Function GenererTableauInsertion(ByVal EnTetes, ByVal colPositions As Collection, _
    ByVal LigneEncours, Optional ByVal Exceptions)
Dim arrTemp() As String, i As Long
 
ReDim arrTemp(0)
If IsMissing(Exceptions) Or Not IsArray(Exceptions) Then
    For i = LBound(EnTetes) To UBound(EnTetes)
        If ExistKey(EnTetes(i), colPositions) Then
            ReDim Preserve arrTemp(UBound(arrTemp) + 2)
            arrTemp(UBound(arrTemp) - 2) = EnTetes(i)
            arrTemp(UBound(arrTemp) - 1) = LigneEncours(colPositions(EnTetes(i)))
        End If
    Next i
Else
    For i = LBound(EnTetes) To UBound(EnTetes)
        If Not look_in_array(EnTetes(i), Exceptions) And ExistKey(EnTetes(i), colPositions) Then
            ReDim Preserve arrTemp(UBound(arrTemp) + 2)
            arrTemp(UBound(arrTemp) - 2) = EnTetes(i)
            arrTemp(UBound(arrTemp) - 1) = LigneEncours(colPositions(EnTetes(i)))
        End If
    Next i
End If
GenererTableauInsertion = arrTemp
End Function
 
 
 
' obtenir la correspondance champs Excel/champs table
Private Function RetrouverChampsExcel(ByVal ListFields, ByVal LigneEncours, ByRef colPosition As Collection) As Boolean
Dim i As Long, lngPosition As Long
Dim lngFound As Long
 
Set colPosition = New Collection ' vider la collection
' on récupère les positions des colonnes de la table textes
For i = LBound(LigneEncours) To UBound(LigneEncours)
    If look_in_array(LigneEncours(i), ListFields, lngPosition) Then
        colPosition.Add i, ListFields(lngPosition)
        lngFound = lngFound + 1
    End If
Next i
 
' retourner TRUE si au moins 5 des champs de la table ont été retrouvés
RetrouverChampsExcel = lngFound >= 5
 
End Function
 
 
 
' insertion via objet ADO: Tablename = table de destination
' InsertValues = (champ1, valeur1, champ2, valeur2, etc)
Public Function FN_INSERT(ByVal Tablename As String, ByVal InsertValues As _
    Variant, Optional ByVal InsertIdFilename As String = "", Optional ByRef _
    InsertIdValue As Long) As Boolean
Dim oRS As DAO.Recordset, i As Long
 
On Error GoTo FN_INSERT_Error
 
Set oRS = CurrentDb.OpenRecordset(Tablename, dbOpenDynaset, dbSeeChanges)
With oRS
    ' nécessaire pour ajouter à la fin, sinon écrase l'enregistrement en cours.
    If Not .EOF Then .MoveLast
    .AddNew
    For i = LBound(InsertValues) To UBound(InsertValues) - 1 Step 2
        If Not IsEmpty(InsertValues(i + 1)) Then
            Select Case .Fields(InsertValues(i)).Type
            Case adDate, adDBDate, adDBTime, adDBTimeStamp
                .Fields(InsertValues(i)).Value = CDate(Replace(InsertValues(i + _
                    1), "'", ""))
            Case Else
                .Fields(InsertValues(i)).Value = InsertValues(i + 1)
            End Select
        End If
    Next i
    .Update
    If InsertIdFilename <> "" Then .Move 0, .LastModified: InsertIdValue = _
        .Fields(InsertIdFilename).Value
    .Close
End With
FN_INSERT = True
 
Exit Function
FN_INSERT_Error:
If Err.Number = 3421 Then
    MsgBox "Donnée de type incorrect, colonne: " & InsertValues(i) & " = " & _
        InsertValues(i + 1) & vbCrLf & "Error " & Err.Number & " (" & _
        Err.Description & ") in Function FN_INSERT of Module mdSql", vbCritical
Else
    MsgBox "Error " & Err.Number & " (" & Err.Description & _
        ") in Function FN_INSERT of Module mdSql", vbCritical
End If
End Function