IMPORTER UNE FEUILLE EXCEL VERS UNE TABLE ACCESS EXISTANTE

' 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

22 février 2007 12:26:51 :

Correction d'un bug dans la dernière fonction pour obtenir le last ID inséré... .Move 0, .LastModified (sans ça j'avais le ID-1)

16 mars 2007 09:34:08 :

information sur la référence aux objets Excel à ajouter. Sinon évidemment ça marche beaucoup moins bien ^^