XL 2013 Ajouter plusieurs tables Access dans Excel

zoidberg

XLDnaute Nouveau
Salut à tous, je viens à vous car on m'a pose une colle au bureau...

J'ai une base de donnes Access avec plusieurs tables dedans, j'aimerais, pour compiler ces données, les importer dans excel. Mais pour simplifier la procedure chaque jour j'aimerais le faire dans une macro ( un gros bouton importer et voila).

J'ai donc fait un enregistrement de macro et fait mon import dans Excel, tout ce passe bien, le problème est que quand je ferme mon fichier et le rouvre et relance la macro, la j'ai un bug...

Si vous avez des idées pour faire cette tache de manière rapide et propre je suis preneur

(mes connaissances Excel sont très limitées)

Merci d'avance ! :)
 

Bougla972

XLDnaute Occasionnel
zoidberg,

Code ci-dessous issue de l'enregistreur de macro.

VB:
Application.DisplayAlerts = False
    'Chemin BD => 'à adapter
    ActiveSheet.Cells.Clear
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:=Array( _
        "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Password="""";User ID=Admin;Data Source=Chemin BD" _
        , _
        ";Mode=Share Deny Write;Extended Properties="""";Jet OLEDB:System database="""";Jet " _
        , _
        "OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine Type=6;Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global" _
        , _
        " Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password="""";Jet OLEDB:Create System Database=Fal" _
        , _
        "se;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False;" _
        , "Jet OLEDB:SFP=False;Jet OLEDB:Support Complex Data=False"), Destination:= _
        Range("$A$1")).QueryTable
        .CommandType = xlCmdTable
        .CommandText = Array("Nom de la table") 'à adapter
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .SourceDataFile = _
        "Chemin de la source" 'à adapter
        .ListObject.DisplayName = "Nom a donner" 'à adapter
        .Refresh BackgroundQuery:=False
    End With
Application.DisplayAlerts = True

Est-ce bien ce type de code que tu as généré ? Cela marche correctement pour moi.
 

zoidberg

XLDnaute Nouveau
VB:
Sub import()
'
' import Macro
'

'
    Workbooks("Book1").Connections.AddFromFile _
        "C:\Users\thibaud.nicolazi\Desktop\Thibaud\Postie 2017.accdb", True, False
    ActiveWorkbook.Worksheets.Add
    [B]With ActiveSheet.ListObjects.Add(SourceType:=4, Source:=ActiveWorkbook.Connections("Postie 2017"), Destination:=Range("$A$1")).TableObject[/B]
        .RowNumbers = False
        .PreserveFormatting = True
        .RefreshStyle = 1
        .AdjustColumnWidth = True
        .ListObject.DisplayName = "Table_Data_Arbitrage"
        .Refresh
    End With
    ActiveWorkbook.Worksheets.Add
    With ActiveSheet.ListObjects.Add(SourceType:=4, Source:=ActiveWorkbook. _
        Connections("Postie 2017"), Destination:=Range("$A$1")).TableObject
        .RowNumbers = False
        .PreserveFormatting = True
        .RefreshStyle = 1
        .AdjustColumnWidth = True
        .ListObject.DisplayName = "Table_Data_Arbitrage_DBM_Printed_Matter"
        .Refresh
    End With
    ActiveWorkbook.Worksheets.Add
    With ActiveSheet.ListObjects.Add(SourceType:=4, Source:=ActiveWorkbook. _
        Connections("Postie 2017"), Destination:=Range("$A$1")).TableObject
        .RowNumbers = False
        .PreserveFormatting = True
        .RefreshStyle = 1
        .AdjustColumnWidth = True
        .ListObject.DisplayName = "Table_Data_Arbitrage_SGO"
        .Refresh
    End With
    ActiveWorkbook.Worksheets.Add
    With ActiveSheet.ListObjects.Add(SourceType:=4, Source:=ActiveWorkbook. _
        Connections("Postie 2017"), Destination:=Range("$A$1")).TableObject
        .RowNumbers = False
        .PreserveFormatting = True
        .RefreshStyle = 1
        .AdjustColumnWidth = True
        .ListObject.DisplayName = "Table_Data_Direct_Entry"
        .Refresh
    End With
    ActiveWorkbook.Worksheets.Add
    With ActiveSheet.ListObjects.Add(SourceType:=4, Source:=ActiveWorkbook. _
        Connections("Postie 2017"), Destination:=Range("$A$1")).TableObject
        .RowNumbers = False
        .PreserveFormatting = True
        .RefreshStyle = 1
        .AdjustColumnWidth = True
        .ListObject.DisplayName = "Table_Data_Parcels"
        .Refresh
    End With
    ActiveWorkbook.Worksheets.Add
    With ActiveSheet.ListObjects.Add(SourceType:=4, Source:=ActiveWorkbook. _
        Connections("Postie 2017"), Destination:=Range("$A$1")).TableObject
        .RowNumbers = False
        .PreserveFormatting = True
        .RefreshStyle = 1
        .AdjustColumnWidth = True
        .ListObject.DisplayName = "Table_Data_Press"
        .Refresh
    End With
    ActiveWorkbook.Worksheets.Add
    With ActiveSheet.ListObjects.Add(SourceType:=4, Source:=ActiveWorkbook. _
        Connections("Postie 2017"), Destination:=Range("$A$1")).TableObject
        .RowNumbers = False
        .PreserveFormatting = True
        .RefreshStyle = 1
        .AdjustColumnWidth = True
        .ListObject.DisplayName = "Table_Data_Terminal_Dues_LP"
        .Refresh
    End With
    ActiveWorkbook.Worksheets.Add
    With ActiveSheet.ListObjects.Add(SourceType:=4, Source:=ActiveWorkbook. _
        Connections("Postie 2017"), Destination:=Range("$A$1")).TableObject
        .RowNumbers = False
        .PreserveFormatting = True
        .RefreshStyle = 1
        .AdjustColumnWidth = True
        .ListObject.DisplayName = "Table_Data_Terminal_Dues_SP"
        .Refresh
    End With
End Sub


Voila le code que j'ai pour cette macro, ca fonctionne aussi... mais que une fois. En gras la ligne qui plante
 

zoidberg

XLDnaute Nouveau
Bonjour Pierre,

Ton fichier semble fonctionner, en revanche j'ai quelques soucis.

Comment je peux faire pour sélectionner les tables Access que je veux importer ? Car actuellement, ton fichier importe toutes les tables présentes dans mon fichier Access...

Et ensuite il me met une erreur "overflow" je suppose que c'est parce que certaines des tables dans Access dépassent le nombre maximum de lignes de Excel.

Je vais également tenter d'adapter ton code Bougla.

Merci.
 
Dernière édition:

zoidberg

XLDnaute Nouveau
Je ne sais pas si cela a une importance particulière mais ce sont des requêtes Access et non des Tables que je souhaite importer.

Dans ce fichier Access j'ai un nombre important de requêtes, je souhaite en importer seulement 8 d'entres elles, que les onglets Excel crées soient au nom de la requête importée et puisse être mis à jour sans décaler tous les onglets.
 

zoidberg

XLDnaute Nouveau
Salut tout le monde !
J'ai finalement réussit a faire mon import depuis Access grace au code suivant :

Code:
Private Sub Command0_Click()
strPath = "Chemin de mon fichier"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Arbitrage", strPath
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Arbitrage DBM&Printed Matter", strPath
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Arbitrage SGO", strPath
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Direct Entry", strPath
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Parcels", strPath
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Press", strPath
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Terminal Dues LP", strPath
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Terminal Dues SP", strPath

End Sub

J'ai maintenant un second soucis... j'aimerais supprimer ceraines plages de cellules sur mon classeur excel avant d'importer les donnees, j'ai donc rajouter ceci avant mon import :

Code:
Dim xlApp As Excel.Application
    Dim xlSheet As Excel.Worksheet
    Dim xlBook As Excel.Workbook
    Dim i As Long
    Dim vtemp As Variant
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open("Chemin de mon fichier")
Set xlSheet = x1Book.Data_Arbitrage
xlSheet.Range("A:AA").ClearContent

J'ai une erreur Run time 424 Object Required...
sur la ligne Set xlSheet = x1Book.Data_Arbitrage

Vous avez une idée de ce qui ne vas pas ?
 

zoidberg

XLDnaute Nouveau
Salut Bougla,

j'avais malencontreusement écrit x1Book et non xlbook, j'ai corrigé mais j'ai maintenant une erreur :

Run time error '91' Object variable or With block variable not set

Voila mon code entier :
VB:
Private Sub Command0_Click()

    Dim xlApp As Excel.Application
    Dim xlSheet As Excel.Worksheet
    Dim xlBook As Excel.Workbook
    Dim i As Long
    Dim vtemp As Variant
  
Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Open("C:\Users\thibaud.nicolazi\Desktop\test.xlsm")
Set xlSheet = xlBook.test.Sheets("Data_Arbitrage")
xlWs.Range("A:AA").ClearContent
strPath = "C:\Users\thibaud.nicolazi\Desktop\test.xlsm"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Arbitrage", strPath
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Arbitrage DBM&Printed Matter", strPath
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Arbitrage SGO", strPath
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Direct Entry", strPath
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Parcels", strPath
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Press", strPath
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Terminal Dues LP", strPath
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Terminal Dues SP", strPath

End Sub
 
Dernière édition:

zoidberg

XLDnaute Nouveau
Toujours le meme message d'erreur : 91 Object variable or with block variable not set

Mon code :
VB:
Option Compare Database

Private Sub Command0_Click()

    Dim xlApp As Excel.Application
    Dim xlSheet As Excel.Worksheet
    Dim xlBook As Excel.Workbook
    Dim i As Long
    Dim vtemp As Variant
  
Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Open("C:\Users\thibaud.nicolazi\Desktop\test.xlsm")
Set xlSheet = x1Book.Sheets(".Data_Arbitrage")
xlWs.Range("A:AA").ClearContent
strPath = "C:\Users\thibaud.nicolazi\Desktop\test.xlsm"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Arbitrage", strPath
'DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Arbitrage DBM&Printed Matter", strPath
'DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Arbitrage SGO", strPath
'DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Direct Entry", strPath
'DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Parcels", strPath
'DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Press", strPath
'DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Terminal Dues LP", strPath
'DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Data Terminal Dues SP", strPath

End Sub
 

Discussions similaires

Réponses
0
Affichages
200