Importer une feuille excel vers une table access existante

Commenter

Contenu du snippet

Le code est suffisemment adaptable pour pouvoir repérer le début et la fin de la table dans une feuille, pour pouvoir retrouver l'ordre des champs même s'il n'est pas identique dans la feuille Excel ou même s'ils n'y sont pas tous.
Si la table Access est bien définie, les champs NOT NULL (null non autorisés) ont tous une valeur par défaut, donc s'il manque un une colonne dans Excel ça ne porte pas à conséquence. Dans le cas contraire ça peut faire planter le code donc veillez à bien définir vos tables Access ou alors fournir un fichier Excel à importer qui soit nikel.

Le code est séparé en plusieurs fonctions indépendantes:
La 1ere fonction (maitre) fait l'importation dans la table du fichier excel fourni en argument, et renvoie le nombre de lignes insérés. Il est facile de monter en 2nd argument le nom de la table source (ici "VEILLE" en dur dans cette fonction)

La 2eme fonction (GetFields) récupère la liste des champs d'une table dans un tableau

La 3eme fonction vérifie l'existence d'une clé dans une collection (!) (pas trouvé ça en natif dans le langage!)

La 4eme (look_in_array) recherche une valeur (Lookup) dans un tableau (in_array), renvoie la position (dans Position) si trouvé, et True (false sinon)

La 5eme fonction (GetExcelLine) lit une ligne complète du fichier Excel

La 6eme (GenererTableauInsertion) transforme cette ligne en un tableau à insérer dans la table

la 7eme (RetrouverChampsExcel) permet d'obtenir la correspondance champs Excel/champs table Access pour la génération du tableau précédent

La 8eme enfin (FN_INSERT) est un INSERT par méthode ADO qui permet d'avoir un msg d'erreur précis (si une colonne n'a pas le bon type, n'est pas renseigné...) et de récupérer l'id de la ligne insérée si besoin (pas besoin ici)

Source / Exemple : 


' 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

Conclusion :


La fonction est assez souple pour s'adapter à pas mal de cas de figure mais pas encore assez à mon gout: à prévoir encore:
- le nom de la table (inscrit dans la fonction)
- la feuille du fichier excel à importer (la 1ere ici, inscrit dans la fonction)
sinon je me base sur le principe que si on trouve X cellules vides on considère qu'on a atteind la fin de la ligne/ de la feuille. pas forcément le meilleur choix mais j'ai pas encore trouvé mieux.

PS: en fait mon code manipule les objets Excel, il faut donc ajouter cette référence: dans l'éditeur VBA:
menu outil / référence: rechercher "Microsoft Excel xx Object Library", cocher valider et c bon ça devrait marcher.

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (pifou25)