Soyez le premier à donner votre avis sur cette source.
Snippet vu 47 908 fois - Téléchargée 22 fois
' 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
SVP; je veux utuliser ces fonctions; mais je ne sais pas quoi mettre dans :
SysCmd acSysCmdSetStatus, "Importation..."
car il me donne error 9 .....in Function ImportExcelVeille of Module mdImportExcel
on mit la plage "Feuil1!A1:F50"
svp c urgent
version d'excel?
message d'erreur?
symptomes?
c'est grave docteur?
stDocName = "Fm_NOUVEAU.import"
DoCmd.RunMacro stDocName
et dans ma macro : runcode ImportExcelVeille («Filename»). Mais bien sur, cela ne fonctionne pas. J'ai remplacé le "filename" par le chemin d'accès et le nom de mon fichier excell.
Je dois avoir oublié quelque chose mais je ne sais pas quoi.
En vous remerciant
Autre solution plus facile: :~)
http://www.vbfrance.com/tutoriaux/IMPORT-FEUIL-EXCEL-DANS-TABLE-ACCESS_638.aspx
Merci beaucoup taikibaybay et Pifou25 aussi!
http://www.vbfrance.com/codes/ACCESS-VBA-EXPORTER-SQL-VERS-FICHIER-PLAT-CSV_41481.aspx
le principe est simple, une fonction qui exporte ta requête access en fichier csv (donc que tu pourra ouvrir avec Excel)
Function ExportCsv(SQL As String, File_name As String, Optional ByVal sep As String ";", Optional ByVal Quote As String "", Optional ByVal WithFields As Boolean = False) As Boolean
ça dit tout: ExportCsv('ta_requete', 'c:/documents/tonfichier.csv')
le tour est joué ;)
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.