IMPORT AUTO EXCEL dans ACCESS

[steph71]

Bonsoir le forum,

je bosse depuis plusieurs jours sur une macro excel qui m'envoie les données d'une feuille EXCEL vers une base ACCESS (cf détail fichier joint) et je bute sur deux pbs majeurs :

1/ je n'arrive pas à faire en sorte que mes 7 derniers champs soient importées dans ACCESS en format numérique,

2/ si un champ n'est pas renseigné, j'ai un message d'erreur.
Comment faire en sorte que l'import s'exécute même si un élément d'un ligne est vide

Merci d'avance pour votre aide
Bonne soirée

STEPH
[file name=CodeVBA.zip size=6648]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/CodeVBA.zip[/file]

 

[_Thierry]

Bonsoir Steph, le Forum

Une correction rapide de ton code...

Option Explicit
Option Compare Text

Const Table As String = 'Statdépositaire_Historique_Facturation'
Const Path As String = 'C:\Documents and Settings\te\My Documents\TestAccess\Test.MDB'

Sub CreateTable()
Dim cat As New ADOX.Catalog
Dim tbl As New ADOX.Table
Dim Conn As New ADODB.Connection
Dim rsT As New ADODB.Recordset
Dim maNouvelleTable As String
Dim i As Byte

Dim TabPlage As Variant
Dim L As Long, C As Byte
Dim SentString As String


maNouvelleTable = Table
maNouvelleTable = Application.WorksheetFunction.Substitute(maNouvelleTable, ' ', '')

    With Conn
        .Provider = 'Microsoft.JET.OLEDB.4.0'
        .Open Path
    End With
       

    With cat
    .ActiveConnection = Conn
        On Error Resume Next
        .Tables.Delete maNouvelleTable
        On Error GoTo 0
    End With
   
    With tbl
        .Name = maNouvelleTable
        With .Columns
            .Append 'Année comptable'                        'Champs 0
            .Append 'Mois comptable'                          'Champs 1
            .Append 'Compte'                                  'Champs 2
            .Append 'Code Déposit'                            'Champs 3
            .Append 'Devise'                                  'Champs 4
            .Append 'Compte BBH'                              'Champs 5
            .Append 'Année référence'                        'Champs 6
            .Append 'Mois référence'                          'Champs 7
            .Append 'Périodicité'                            'Champs 8
            .Append 'Nb mois'                                'Champs 9
            .Append 'Nature'                                  'Champs 10
            .Append 'TDB Encours (LDP €)', adDouble          'Champs 11 Numeric
            .Append 'Encours facturé (devise)', adDouble      'Champs 12 Numeric
            .Append 'Encours facturé (€)', adDouble          'Champs 13 Numeric
            .Append 'Volume', adDouble                        'Champs 14 Numeric
            .Append 'Tarif (devise) ou pb annuels', adDouble  'Champs 15 Numeric
            .Append 'Montant (devise)', adDouble              'Champs 16 Numeric
            .Append 'Montant (€)', adDouble                  'Champs 17 Numeric
        End With
    End With
 
        cat.Tables.Append tbl
   
    With rsT
        .ActiveConnection = Conn
        .Open maNouvelleTable, LockType:=adLockOptimistic
    End With
   
    With Feuil2
        TabPlage = .Range('A2:R' & .Range('A65536').End(xlUp).Row)
    End With

                       
    For L = 1 To UBound(TabPlage)
        With rsT
            .AddNew
                For C = 1 To 18
                SentString = IIf(TabPlage(L, C) = Empty, 0, TabPlage(L, C))
                .Fields(C - 1).Value = SentString
                Next
            .Update
        End With
    Next L
   
   
    rsT.Close
    Set tbl = Nothing
    Set cat = Nothing
    Conn.Close
 
MsgBox 'Export terminé'
 
End Sub

Pour les Valeur Numériques no soucy sous Office XP Pro (2002) avec 'adDouble' pour le Type As DataTypeEnum...

Par contre tel quel, j'ai bien essayé 'adIUnknown' ou 'adPropVariant' pour le Type As DataTypeEnum... Mais ça ne passe pas... Par conséquent dans ma boucle barbatruqueste j'envoie des zéros si vides...

Ca peut te dépanner...

[ol]@+Thierry[/ol]

 

[steph71]

Bonjour Thierry
Tout d'abord merci pour ta contribution.
Cela me dépanne effectivement.
Maintenant, si pour les champs 11 à 17, cela ne me pose pas de pb de renvoyer 0 quand la cellule est vide, c'est plus problématique pour les champs 0 à 10.
Ne peut on vraiment pas renvoyer une chaîne de caractères (ex : non renseigné) pour ces champs ??

Merci d'avance

STEPH71

 

[_Thierry]

Bonjour Steph, le Forum

Je n'ai pas vu ta réponse/question hier.

Je pense que l'on peut encore 'babarbtruquer' sur ce coup là en complémentant la boucle de la sorte :

For L = 1 To UBound(TabPlage)
      With rsT
          .AddNew
              For C = 1 To 18
                  Select Case C
                      Case 1 To 11
                          SentString = IIf(TabPlage(L, C) = Empty, 'Empty', TabPlage(L, C))
                      Case 12 To 18
                          SentString = IIf(TabPlage(L, C) = Empty, 0, TabPlage(L, C))
                  End Select
              .Fields(C - 1).Value = SentString
            Next
          .Update
      End With
  Next L

Ce n'est pas le plus académique, en fait il faudrait trouver le paramètre qui permettrait à Access d'acepter des Champs Vides...

Bonne Journée
[ol]@+Thierry[/ol]

 

[MichelXld]

bonjour Steph , bonjour cher ami @+Thierry

pour que des champs acceptent des enregistrements Null , tu peux tester

Dim j As Integer

'....
'
With tbl
.Name = maNouvelleTable
With .Columns
.Append 'Année comptable' 'Champs 0
.Append 'Mois comptable' 'Champs 1
.Append 'Compte' 'Champs 2
.Append 'Code Déposit' 'Champs 3
.Append 'Devise' 'Champs 4
.Append 'Compte BBH' 'Champs 5
.Append 'Année référence' 'Champs 6
.Append 'Mois référence' 'Champs 7
.Append 'Périodicité' 'Champs 8
.Append 'Nb mois' 'Champs 9
.Append 'Nature' 'Champs 10
.Append 'TDB Encours (LDP €)', adDouble 'Champs 11 Numeric
.Append 'Encours facturé (devise)', adDouble 'Champs 12 Numeric
.Append 'Encours facturé (€)', adDouble 'Champs 13 Numeric
.Append 'Volume', adDouble 'Champs 14 Numeric
.Append 'Tarif (devise) ou pb annuels', adDouble 'Champs 15 Numeric
.Append 'Montant (devise)', adDouble 'Champs 16 Numeric
.Append 'Montant (€)', adDouble 'Champs 17 Numeric
End With
End With

For j = 0 To Tbl.Columns.Count - 1
Tbl.Columns(j).Attributes = adColNullable
Next j
'...
Cat.Tables.Append Tbl



bonne journée
MichelXld

 

[steph71]

Bonjour,
je viens de tester ta proposition et l'export se déroule toujours bien, simplement il me remplace les cellules vides par 0, ce qui me pose pb.

 

[steph71]

Bonjour,
suite à mon message précédent, il faudrait, je pense, affecter aux champs 0 à 10 la propriété qui permet d'autoriser les chaîne vides.

 

[MichelXld]

bonjour Steph , bonjour @+Thierry

Steph , as tu testé la modification que je t'ai proposé ?


Option Explicit
Option Compare Text

Const Table As String = 'Statdépositaire_Historique_Facturation'
Const Path As String = 'C:\\\\\\\\Documents and Settings\\\\\\\\michel\\\\\\\\excel\\\\\\\\dataBase.mdb'

Sub CreateTable()
Dim Cat As New ADOX.Catalog
Dim Tbl As New ADOX.Table
Dim Conn As New ADODB.Connection
Dim rsT As New ADODB.Recordset
Dim maNouvelleTable As String
Dim i As Byte
Dim TabPlage As Variant
Dim L As Long, C As Byte
Dim j As Integer

maNouvelleTable = Table

With Conn
.Provider = 'Microsoft.JET.OLEDB.4.0'
.Open Path
End With

With Cat
.ActiveConnection = Conn
On Error Resume Next
.Tables.Delete maNouvelleTable
On Error GoTo 0
End With

With Tbl
.Name = maNouvelleTable
With .Columns
.Append 'Année comptable' 'Champs 0
.Append 'Mois comptable' 'Champs 1
.Append 'Compte' 'Champs 2
.Append 'Code Déposit' 'Champs 3
.Append 'Devise' 'Champs 4
.Append 'Compte BBH' 'Champs 5
.Append 'Année référence' 'Champs 6
.Append 'Mois référence' 'Champs 7
.Append 'Périodicité' 'Champs 8
.Append 'Nb mois' 'Champs 9
.Append 'Nature' 'Champs 10
.Append 'TDB Encours (LDP €)', adDouble 'Champs 11 Numeric
.Append 'Encours facturé (devise)', adDouble 'Champs 12 Numeric
.Append 'Encours facturé (€)', adDouble 'Champs 13 Numeric
.Append 'Volume', adDouble 'Champs 14 Numeric
.Append 'Tarif (devise) ou pb annuels', adDouble 'Champs 15 Numeric
.Append 'Montant (devise)', adDouble 'Champs 16 Numeric
.Append 'Montant (€)', adDouble 'Champs 17 Numeric
End With
End With

For j = 0 To Tbl.Columns.Count - 1
Tbl.Columns(j).Attributes = adColNullable
Next j

Cat.Tables.Append Tbl

With rsT
.ActiveConnection = Conn
.Open maNouvelleTable, LockType:=adLockOptimistic
End With

With Feuil2
TabPlage = .Range('A2:R' & .Range('A65536').End(xlUp).Row)
End With


For L = 1 To UBound(TabPlage)
With rsT
.AddNew
For C = 1 To 18
.Fields(C - 1).Value = TabPlage(L, C)
Next
.Update
End With
Next L

rsT.Close
Set Tbl = Nothing
Set Cat = Nothing
Conn.Close

MsgBox 'Export terminé'
End Sub


bonne journée
MichelXld

 

[steph71]

Bonjour Michel et le forum,
je n'avais pas effectivement testé la modification de la boucle proposé par THIERRY.
Désormais cela fonctionne.
Mais j'ai un dernier souci.
Normalement, la base ACCESS de destination est protégée par un mot de passe.
Or, j'ai du supprimer celui ci pour que l'export fonctionne car, à défaut, j'avais le message suivant :
Erreur d'exécution
Mot de passe invalide

Comment modifier mon script pour que l'export se fasse malgré le mot de passe

Merci d'avance et bonne journée

 

[MichelXld]

rebonjour

tu peux tester

With Conn
.Provider = 'Microsoft.JET.OLEDB.4.0'
.Properties('Jet OLEDBatabase Password') = 'monMotDePasse'
.Open Path
End With



bonne journée
MichelXld

 

[steph71]

Voilà ce que j'ai mis :
With Conn
.Provider = 'Microsoft.JET.OLEDB.4.0'
.Properties('Jet OLEDBatabase Password')= 'TB'
.Open Path
.Open '\\\\uf11-002\\TITTDB\\CM-CIC_Titres\\Reporting\\Base Access\\TDB_ANNEXES.mdb'
End With

j'ai un message d'erreur de compilation, varibale nom définie (path)

 

[_Thierry]

=> DEMO ADO Export Excel > Access ValNum/Date/Null

Bonjour Steph, cher Michel, le Forum

Merci beaucoup Michel pour la partie 'Attributes = adColNullable' pour permettre d'accepter des Valeurs Nulles dans la Table Access, je ne connaissais pas. C'est cool, merci à toi.

Sinon pour ton 'Path' c'est une Constante en Top de Module que tu dois adapter au chemin complet de ta base Access... (dans ce cas là tu n'as pas besoin de ta seconde ligne .Open '\\uf11-002TITTDBCM-CIC_TitresReportingBase AccessTDB_ANNEXES.mdb')


Sinon vu que le sujet est intéressant et a été bien traité à nous deux avec Michel, j'ai jugé utile d'en faire une chti-Démo

Mode d'Emploi, sauver la Base MDB et le Programme Excel dans le même répertoire....

Attention aux référence de Librairies ADO / ADOX car c'est fait sous 2003 (possible nécessité de rétrograder aux références antérieures si vous testez sous 2000.

Bon Appétit
@+Thierry [file name=XLD_Import_Excel_To_Access.zip size=24930]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/XLD_Import_Excel_To_Access.zip[/file]

 

[MichelXld]

Re:=> DEMO ADO Export Excel > Access ValNum/Date/Null

bonjour cher @+Thierry

merci pour ta démo : je créerai un lien vers ton fichier lors de la prochaine mise à jour de la Wiki Page 6


bon apres midi
MichelXld

 

[steph71]

Re:=> DEMO ADO Export Excel > Access ValNum/Date/Null

Bonjour à tous,

avec l'excellente contribution de Michel et Thierry, mon appli est désormais fiabilisée.
Maintenant, comme le sujet semble passionné, je fais part d'un autre besoin potentiel.
Une fois exporté dans ACCESS, les données sont complétées via une requête.
Ensuite, cette requête sert de base de données à un tableau croisé dynamique sous excel.

Petite Question : Est il possible d'envisager qu'à l'ouverture de ce tableau croisé une info apparaisse et indique la date du dernier import dans ACCESS ?

Bonne réflexion et bonne fin de journée

Steph71

 

[MichelXld]

Re:=> DEMO ADO Export Excel > Access ValNum/Date/Null

bonsoir

cet exemple permet de recuperer la date de la derniere modification d'un table Access

Sub dateDerniereModificationTable_baseAcces()
'necessite d 'activer la reference Microsoft ActiveX Data Objects x.x Library
'necessite d'activer la reference Microsoft ADO Ext. x.x for DDL and Security
Dim Cat As ADOX.Catalog
Dim laTable As ADOX.Table
Dim Fichier As String
Dim Cn As ADODB.Connection

Fichier = 'C:\\\\\\\\dataBase.mdb'

Set Cn = New Connection
With Cn
.Provider = 'Microsoft.Jet.OLEDB.4.0'
'.Properties('Jet OLEDBatabase Password') = 'monMotDePasse'
.Open Fichier
End With

Set Cat = CreateObject('ADOX.Catalog')
Set Cat.ActiveConnection = Cn

Set laTable = Cat.Tables('Statdépositaire_Historique_Facturation')
MsgBox laTable.DateModified

Cn.Close
Set Cn = Nothing
Set Cat = Nothing
End Sub


d'autres infos ici

Ce lien n'existe plus


bonne soirée
MichelXld