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
| Function GetOpenXLfile()
Dim fdlg As Object ' Office.FileDialog
Dim sFichier As String
Set fdlg = Application.FileDialog(1) ' msoFileDialogOpen=1
' Mode vue liste
fdlg.InitialView = 1 ' msoFileDialogViewList=1
' Sélection Multiple
fdlg.AllowMultiSelect = False
' Filtre
fdlg.Filters.Clear
fdlg.Filters.Add "Excel", "*.xls;*.xls?"
' Afficher boîte de dialogue
If fdlg.Show Then
sFichier = fdlg.SelectedItems(1)
End If
Set fdlg = Nothing
' Retourner le nom complet du fichier
GetOpenXLfile = sFichier
End Function
Sub ImporterFichierXL(sFichierXL As String)
Dim db As DAO.Database, tdTmpTbl As DAO.TableDef
Dim rsXL As DAO.Recordset, rsAcc As DAO.Recordset
Dim arrCol3() As String, iIdx As Integer
On Error GoTo ErrH
Set db = CurrentDb
' Supprimer la table temporaire
Set tdTmpTbl = db.TableDefs(CS_TmpTbl)
If Not (tdTmpTbl Is Nothing) Then
Set tdTmpTbl = Nothing
db.TableDefs.Delete CS_TmpTbl
End If
' Importer la 1ère feuille du fichier Excel dans la table temporaire
DoCmd.TransferSpreadsheet acImport, , CS_TmpTbl, sFichierXL, False
' [Optionnel] Vider table Access
If CB_ViderTableAccess Then
db.Execute "DELETE FROM [" & CS_TblAcc & "]"
End If
' Ouvrir les tables avec des recordsets
Set rsAcc = db.OpenRecordset(CS_TblAcc)
Set rsXL = db.OpenRecordset(CS_TmpTbl)
' Boucler sur les enregistrements de rsXL et les ajouter
' dans la table Access de destination
Do While Not rsXL.EOF
' Eclater Colonne 3 en tableau de chaînes de caractères
arrCol3 = Split(Nz(rsXL(2), ""), ";")
' Boucler sur les éléments du tableau
For iIdx = LBound(arrCol3) To UBound(arrCol3)
' Créer un nouvel enregistrement dans la table de destination
rsAcc.AddNew
rsAcc(0) = rsXL(0) ' Colonne 1
rsAcc(1) = rsXL(1) ' Colonne 2
rsAcc(2) = arrCol3(iIdx)
' Enregistrer le nouvel enregistrement
rsAcc.Update
Next
' Passer à l'enregistrement suivant de la table temporaire
rsXL.MoveNext
Loop
ExitProc:
' Fermer les recordsets
If Not (rsAcc Is Nothing) Then
If rsAcc.EditMode <> dbEditNone Then rsAcc.CancelUpdate
rsAcc.Close
End If
If Not (rsXL Is Nothing) Then rsXL.Close
Exit Sub
ErrH:
Select Case Err.Number
Case 3265 ' Element non trouvé dans cette collection
Resume Next
End Select
MsgBox "Erreur No." & Err.Number & " : " & Err.Description, _
vbExclamation, "Sub ImporterFichierXL"
Resume ExitProc
End Sub |
Partager