Ajouter une feuille dans un classeur fermé

[MichelXld]

Bonsoir


Vous trouverez ci joint des procédures qui permettent de créer une nouvelle feuille dans un classeur fermé, par macro en utilisant le modèle ADO.
Ce n'est pas quelque chose de très habituel mais il s'agit avant tout ici de présenter les possibilités associées à Excel.

Ces procédures nécessitent d'activer la référence Microsoft ActiveX Data Objects x.x Library
Dans l'éditeur de macros:
Menu Outils
Références
Cochez la ligne "Microsoft ActiveX Data Objects x.x Library"
Cliquez sur le bouton OK pour valider
x.x dépend de la version installée sur votre poste.



Cet exemple ajoute une nouvelle feuille dans un fichier Excel fermé et y transfére le contenu d'une requête effectuée dans une table Access.

 
Sub tranfertTableAccess_Vers_ClasseurExcelFerme()
    'Nécessite d'activer la référence Microsoft ActiveX Data Objects x.x Library
    'Transfére une Table Access dans un nouvel onglet d'un classeur fermé.
    '
    Dim ExcelCn As ADODB.Connection
    Dim ExcelRst As ADODB.Recordset
    Dim AccessCn As New ADODB.Connection
    Dim AccessRst As New ADODB.Recordset
    Dim maBase As String, maFeuille As String, listeTable As String
    Dim maTable As String, NomClasseur As String
    Dim j As Integer
    Dim Fld As ADODB.Field
    
    'Chemin de la base Access
    maBase = "C:\Documents and Settings\mimi\dossier\dataBase.mdb"
    'Nom de la table Access à transfèrer
    maTable = "Table1"
    'Classeur ou va être créée la nouvelle feuille
    NomClasseur = "C:\leClasseurFermé.xls"
    'Nom de la nouvelle feuille Excel
    maFeuille = "MaNouvelleFeuille"
    
    
    'Connection à la base Access
    AccessCn.Open "provider=microsoft.jet.oledb.4.0; data source=" & maBase
    'Requète dans la table Access
    AccessRst.Open "SELECT * FROM " & maTable, AccessCn, adOpenStatic
    
    'Connection au classeur Excel
    Set ExcelCn = New ADODB.Connection
    ExcelCn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                   "Data Source=" & NomClasseur & ";" & _
                   "Extended Properties=""Excel 8.0;HDR=NO;"""
        
        
    'paramétrage des entêtes et types de données
    For Each Fld In AccessRst.Fields
        listeTable = listeTable & Fld.Name & " " & FieldType(Fld.Type) & ","
    Next Fld
    
    'création nouvelle Feuille Excel
    listeTable = Left(listeTable, Len(listeTable) - 1)
    ExcelCn.Execute "create table " & maFeuille & "(" & listeTable & ")"
    
    
    Set ExcelRst = New ADODB.Recordset
    ExcelRst.Open "Select * from " & maFeuille, ExcelCn, adOpenKeyset, adLockOptimistic
        
    'transfert les données Access vers le classeur Excel
    Do While Not (AccessRst.EOF)
            ExcelRst.AddNew
                For j = 0 To ExcelRst.Fields.Count - 1
                    ExcelRst.Fields(j) = AccessRst.Fields(j).Value
                Next j
            ExcelRst.Update
            AccessRst.MoveNext
    Loop
        
    
    AccessRst.Close
    AccessCn.Close
    Set ExcelRst = Nothing
    Set ExcelCn = Nothing
End Sub

Function FieldType(Valeur As Long) As String
    'Spécification des types de données pour la création des champs Excel.
    'Attention ! la liste est incomplète.
    '
    Select Case Valeur
        Case 6
            FieldType = "currency"
            
        Case 7, 133, 134, 135
            FieldType = "Date"
            
        Case 14, 131
            FieldType = "Decimal"
            
        Case 5
            FieldType = "Float"
        
        Case 3, 2
            FieldType = "Integer"
            
        Case 4
            FieldType = "Real"
            
        Case 200, 202
            FieldType = "Text"
            
        Case 11
            FieldType = "Boolean"
            
        Case 203
            FieldType = "Memo"
            
        Case 16
            FieldType = "Tinyint"
    End Select
End Function

Une deuxième solution pour un résultat identique:

 
Sub tranfertTableAccess_Vers_ClasseurExcelFerme_V02()
    'Nécessite d'activer la référence Microsoft ActiveX Data Objects x.x Library
    'Transfére une Table Access dans un nouvel onglet d'un classeur fermé
    '
    Dim ExcelCn As ADODB.Connection
    Dim ExcelRst As ADODB.Recordset
    Dim AccessCn As New ADODB.Connection
    Dim AccessRst As New ADODB.Recordset
    Dim maBase As String, maFeuille As String
    Dim maTable As String, NomClasseur As String
    Dim nbEnr As Long
    
    'Chemin de la base Access
    maBase = "C:\Documents and Settings\mimi\dossier\dataBase.mdb"
    'Nom de la table Access à transfèrer
    maTable = "Table1"
    'Classeur dans lequel va être créée la nouvelle feuille
    NomClasseur = "C:\leClasseurFermé.xls"
    'Nom de la nouvelle feuille Excel
    maFeuille = "MaNouvelleFeuille2"
    
    
    'Connection à la base Access
    AccessCn.Open "provider=microsoft.jet.oledb.4.0; data source=" & maBase
    'Requète dans la table Access
    AccessRst.Open "SELECT * FROM " & maTable, AccessCn, adOpenStatic
    
    'Connection au classeur Excel
    Set ExcelCn = New ADODB.Connection
    ExcelCn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                   "Data Source=" & NomClasseur & ";" & _
                   "Extended Properties=""Excel 8.0;HDR=NO;"""
        
    'Transfert les données d'Access vers Excel
    AccessCn.Execute "SELECT * INTO [Excel 8.0;" & _
        "Database=" & NomClasseur & "].[" & maFeuille & "] FROM " & maTable, nbEnr
    
    AccessRst.Close
    AccessCn.Close
    Set ExcelRst = Nothing
    Set ExcelCn = Nothing
End Sub

bonne soirée
MichelXld

[Celeda]

Bonjour,


Merci Michel pour ces nouveaux codes!!!

et pour nous faciliter notre ACCESS à EXCEL!!!

[MichelXld]

Bonsoir chère Celeda

Merci pour ton message.

Regarde ce que j'ai retrouvé en faisant le ménage dans mes fichiers: Un logo d'un autre temps, que les moins de ...2 ans ne peuvent pas connaitre ...;o)

Bon fin d'après midi à toi
MichelXld