Fonction d'exportation vers Excel [Sources]

[Muhad'hib]

Ayant souvent besoin de générer des rapports sur Excel d'aprés les données de bases Access, je me suis fait une fonction qui me prépare un rapport sur Excel à partir d'un recordset.

Je la mets ici si elle peut servir à qq'un.

Il n'y a rien de bien original en soit (tout ou presque provient de differents tutoriel ou articles de FAQ)

Voici la fonction et un exemple d'utilisation :


Déclaration de constantes pour garder les constantes d'Excel :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
 
 
Global Const xlPie = 5
Global Const xlDownThenOver = 1
Global Const xlLandscape = 2
Global Const xlPaperA4 = 9
Global Const xlPrintNoComments = -4142
Global Const xlDiagonalUp = 6
Global Const xlDiagonalDown = 5
Global Const xlEdgeLeft = 7
Global Const xlContinuous = 1
Global Const xlMedium = -4138
Global Const xlAutomatic = -4105
Global Const xlEdgeTop = 8
Global Const xlEdgeBottom = 9
Global Const xlEdgeRight = 10
Global Const xlHairline = 1
Global Const xlInsideVertical = 11
Global Const xlInsideHorizontal = 12
Global Const xlNone = -4142
Global Const xlThin = 2
Global Const xlWorksheet = -4167
Global Const xlRight = -4152
Global Const xlLeft = -4131
Global Const xlCenter = -4108
Global Const xlTop = -4160
Global Const xlLocationAsObject = 2
Global Const xlCellValue = 1
Global Const xlEqual = 3

Les arguments sont :
Arg_Path : le chemin du fichier model si il y en a un
Arg_Rs : le recordset contenant les données à exporter
Arg_MEF : mise en forme ou non des données (bordures, couleurs, date ...)
Arg_Ligne : N° de la ligne ou coller les données
Arg_Colonne : N° de la colonne ou coller les données
Arg_Feuil : N° de la feuille à utiliser pour coller les données

Liste des réfrences nécessaires :
Visual Basic for Applications
Micrsoft Access 9.0 Object Library
OLE Automation
Microsoft Activex Data Object Library
Microsoft DAO 3.6 Object Library

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
 
 
Public Function fExportExcel(ByVal Arg_Path As String, ByVal Arg_Rs As DAO.Recordset, Optional ByVal Arg_MEF As Boolean = False, Optional ByVal Arg_Ligne As Integer = 1, Optional ByVal Arg_Colonne As Integer = 1, Optional ByVal Arg_Feuil As Integer = 1) As Object
'Déclarations
    Dim I As Integer
    Dim NbrChamps As Integer
 
    Dim ExcelApp As Object
    Dim Excelsheet As Object
    On Error GoTo fExportExcel_Err
 
'existance d'un fichier modèle
    If Arg_Path & "" = "" Then
        'pas de fichier model
            Set ExcelApp = CreateObject("Excel.application").Workbooks.Add
            Set Excelsheet = ExcelApp.worksheets(Arg_Feuil)
 
 
    Else
        'fichier modèle
            Set ExcelApp = GetObject(Arg_Path)
            Set Excelsheet = ExcelApp.worksheets(Arg_Feuil)
    End If
    ExcelApp.windows(1).Visible = True
 
 
'ExcelApp.Application.Visible = True
 
'existance des données
If Not (Arg_Rs.BOF = True And Arg_Rs.EOF = True) Then
 
    'il y a des données à exporter
        Arg_Rs.MoveLast
        Arg_Rs.MoveFirst
        NbrChamps = Arg_Rs.Fields.Count
 
        'Titre de colonne
        For I = 0 To NbrChamps - 1
            Excelsheet.cells(Arg_Ligne, I + Arg_Colonne) = Arg_Rs(I).Name
        Next
 
        'copie des infos
        Excelsheet.cells(Arg_Ligne + 1, Arg_Colonne).CopyFromRecordset Arg_Rs
        'mise en forme si arg_cadre = true
            If Arg_MEF = True Then
                'datage
                    With Excelsheet.cells(Arg_Rs.RecordCount + Arg_Ligne + 1, NbrChamps - 1 + Arg_Colonne)
                        .Value = "'" & Format(Now, "dd/mm/yyyy")
                        .Font.Size = 6
                        .HorizontalAlignment = xlRight
                    End With
 
                'cadre + couleur des titres
 
                    'with = la zone tableau
 
                        With Excelsheet.Range(Excelsheet.cells(Arg_Ligne, Arg_Colonne), Excelsheet.cells(Arg_Ligne + Arg_Rs.RecordCount, Arg_Colonne + NbrChamps - 1))
                            .Borders(xlInsideVertical).Weight = xlThin
                            .Borders(xlInsideHorizontal).Weight = xlThin
                            .Borders(xlEdgeLeft).Weight = xlMedium
                            .Borders(xlEdgeTop).Weight = xlMedium
                            .Borders(xlEdgeBottom).Weight = xlMedium
                            .Borders(xlEdgeRight).Weight = xlMedium
                            .HorizontalAlignment = xlCenter
                        End With
 
                    With Excelsheet.Range(Excelsheet.cells(Arg_Ligne, Arg_Colonne), Excelsheet.cells(Arg_Ligne, Arg_Colonne + NbrChamps - 1))
                        .Interior.ColorIndex = 37
                        .Borders(xlEdgeBottom).Weight = xlMedium
                        .HorizontalAlignment = xlCenter
                        .EntireColumn.AutoFit
                    End With
 
            End If
End If
 
GoTo fExportExcel_Exit
 
'gestion des erreurs
fExportExcel_Err:
    MsgBox "Une erreur inattendue est apparue dans la fonction fExportExcel. L'erreur N° " & Err.Number & " ( " & Err.Description & " )! Contactez l'administrateur.", vbOKOnly + vbCritical, "Erreur inattendue !"
    Set fExportExcel = Nothing
    Exit Function
 
'Sortie
fExportExcel_Exit:
 
    Set fExportExcel = ExcelApp
    Set ExcelApp = Nothing
    Set Excelsheet = Nothing
 
 
End Function

Petit exemple d'utilisation :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
 
Sub test()
Dim Chemin  As String
Dim Rs As DAO.Recordset
Dim Excl As Object
Dim Sql As String
 
On Error GoTo Test_Err
 
'Chemin = "c:\test.xls"
Chemin = ""
Set Rs = CurrentDb.OpenRecordset("T_test", dbOpenDynaset)
Set Excl = fExportExcel(Chemin, Rs, True, 2, 1)
If Excl.Name <> "" Then
    'Autres manipulation du classeur
    Excl.Application.Visible = True
    Excl.sheets(1).cells(1, 1) = "titre du document"
    Excl.saveas "c:\test_bis.xls"
    Excl.Application.Quit
    Set Excl = Nothing
End If
Exit Sub
Test_Err:
 
If Err.Number <> 91 Then
 
MsgBox "Une erreur inattendue est apparue dans la fonction Test. L'erreur N° " & Err.Number & " ( " & Err.Description & " )! Contactez l'administrateur.", vbOKOnly + vbCritical, "Erreur inattendue !"
 
 
End If
Set Excl = Nothing
Set Rs = Nothing
 
End Sub

Les commantaires sont les bienvenus !

[Puffcash]

Salut,

Super ton exemple, j'ai pu m'en servir même en étant débutant ( je comprenais pas tout à la Faq).

j'ai qd même un erreur qui s'affiche :
"une erreur inatendue est apparu dans la fonctio Test. L'erreur N°438 (propriété ou methode non gérée par cette objet )! contacter l'administrateur"

Ca n'empèche pas l'export, mais si ce message pourvait au moins ne pas être affiché...

Sinon, autre chose, j'aimerais exporter vers un onglet précis en indiquant dans la fonction le nom de l'onglet et non pas le numéro de feuille.

(et j'aimerais ne pas importer les intitulés des champs (premiere ligne))

Merci

[Lou Pitchoun]

Salut,
Ce serait bien d'avoir un peu plus d'explications sur l'erreur... La ligne en cause par exemple.
Mais si tu as suivi tout ce que Muhad'hib a écrit, il ne devrait pas y avoir de problèmes...

[Puffcash]

salut kikof,
d'abord merci pour ta réponse,

J'ai retiré :

Code :

1
2
3
4
5
6
'    'Autres manipulation du classeur
    Excl.Application.Visible = True
    Excl.cells(1, 1) = "titre du document"
    Excl.saveas "c:\test_bis.xls"
    Excl.Application.Quit
    Set Excl = Nothing

et ya plus de probleme.
Ca c'est résolu, mais pour le nom de la feuille ? et retirer l'import des intitulés ?
Un petit coup de pouce serait le bien venu... c'est la dernière chose qui me permettrait de finir mon stage en beauté

Merci

[Lou Pitchoun]

A la place de

Code :

Optional ByVal Arg_Feuil As Integer = 1

tu mets

Code :

Optional ByVal Arg_Feuil As String

Et quand tu appelles la fonction : tu mets le nom de la feuille.

[Muhad'hib]

Salut,

+1 pour les réponses de Kikof

Juste si tu veux passer le nom de l'onglet, ajoute un test pour vérifier qu'il existe.
Peut-être aussi le laisser en optionel :
-si tu passe une valeur verif que l'onglet existe et utilise le
-si tu ne passe pas de valeur, utilise l'onglet index 1


N'hésite pas à mettre le code ici.

A+

[Puffcash]

Merci à vous deux,

Je peux maintenant sectionner la feuille d'export par son nom.
Pour répondre à Muhad'hib, j'aimerais énormément contribuer à l'évolution de cet exemple en ajoutant le test :
-si tu passe une valeur verif que l'onglet existe et utilise le
-si tu ne passe pas de valeur, utilise l'onglet index 1

Mais j'ai bien peur de ne pas avoir les compétences pour cela. Par exemple, je n'ai aucune idée de code pour tester si oui ou non le nom de la feuille demandée existe.

Sinon que faut-il rajouter pour ne pas exporter la première ligne concernant le nom des champ ?

Merci

[Muhad'hib]

Re,

Les entêtes de colonnes sont renseignées par les lignes :

Code :

1
2
3
4
5
 
'Titre de colonne
        For I = 0 To NbrChamps - 1
            Excelsheet.cells(Arg_Ligne, I + Arg_Colonne) = Arg_Rs(I).Name
        Next

Si tu ne les veux pas, enlèves ces ligne. Tu devra aussi modifier les lignes qui mettent en forme (mise en couleur et bordures).

A+

[Muhad'hib]

J'ai corrigé la source de l'erreur :

Code :

1
2
 
Excl.cells(1, 1) = "titre du document"

devient :

Code :

1
2
 
Excl.sheets(1).cells(1, 1) = "titre du document"

A+

[Muhad'hib]

Re (encore),

Voici un code qui devrait correspondre à ton besoin :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
 
 
Public Function fExportExcel(ByVal Arg_Path As String, ByVal Arg_Rs As DAO.Recordset, Optional ByVal Arg_MEF As Boolean = False, Optional ByVal Arg_Ligne As Integer = 1, Optional ByVal Arg_Colonne As Integer = 1, Optional ByVal Arg_Feuil As String, Optional ByVal Arg_entete As Boolean = True) As Object
'Déclarations
    Dim I As Integer
    Dim NbrChamps As Integer
    Dim Entete As Integer
    Dim ExcelApp As Object
    Dim Excelsheet As Object
    On Error GoTo fExportExcel_Err
 
    If Arg_entete = True Then
        Entete = 1
    Else
        Entete = 0
    End If
'existance d'un fichier modèle
    If Arg_Path & "" = "" Then
        'pas de fichier model
            Set ExcelApp = CreateObject("Excel.application").Workbooks.Add
            For I = 1 To ExcelApp.worksheets.Count
                If ExcelApp.worksheets(I).Name = Arg_Feuil Then
                    Set Excelsheet = ExcelApp.worksheets(Arg_Feuil)
                    Exit For
                End If
            Next
 
            If I = ExcelApp.worksheets.Count + 1 Then
                'le nom de feuille n'existe pas
                Set Excelsheet = ExcelApp.worksheets(1)
            End If
 
 
 
    Else
        'fichier modèle
            Set ExcelApp = GetObject(Arg_Path)
            For I = 1 To ExcelApp.worksheets.Count
                If ExcelApp.worksheets(I).Name = Arg_Feuil Then
                    Set Excelsheet = ExcelApp.worksheets(Arg_Feuil)
                    Exit For
                End If
            Next
 
            If I = ExcelApp.worksheets.Count + 1 Then
                'le nom de feuille n'existe pas
                Set Excelsheet = ExcelApp.worksheets(1)
            End If
    End If
    ExcelApp.windows(1).Visible = True
 
 
'ExcelApp.Application.Visible = True
 
'existance des données
If Not (Arg_Rs.BOF = True And Arg_Rs.EOF = True) Then
 
    'il y a des données à exporter
        Arg_Rs.MoveLast
        Arg_Rs.MoveFirst
        NbrChamps = Arg_Rs.Fields.Count
 
        If Arg_entete = True Then
        'Titre de colonne
            For I = 0 To NbrChamps - 1
                Excelsheet.cells(Arg_Ligne, I + Arg_Colonne) = Arg_Rs(I).Name
            Next
        End If
        'copie des infos
        Excelsheet.cells(Arg_Ligne + Entete, Arg_Colonne).CopyFromRecordset Arg_Rs
        'mise en forme si arg_cadre = true
            If Arg_MEF = True Then
                'datage
                    With Excelsheet.cells(Arg_Rs.RecordCount + Arg_Ligne + Entete, NbrChamps - 1 + Arg_Colonne)
                        .Value = "'" & Format(Now, "dd/mm/yyyy")
                        .Font.Size = 6
                        .HorizontalAlignment = xlRight
                    End With
 
                'cadre + couleur des titres
 
                    'with = la zone tableau
 
                        With Excelsheet.Range(Excelsheet.cells(Arg_Ligne, Arg_Colonne), Excelsheet.cells(Arg_Ligne + Arg_Rs.RecordCount - 1 + Entete, Arg_Colonne + NbrChamps - 1))
                            .Borders(xlInsideVertical).Weight = xlThin
                            .Borders(xlInsideHorizontal).Weight = xlThin
                            .Borders(xlEdgeLeft).Weight = xlMedium
                            .Borders(xlEdgeTop).Weight = xlMedium
                            .Borders(xlEdgeBottom).Weight = xlMedium
                            .Borders(xlEdgeRight).Weight = xlMedium
                            .HorizontalAlignment = xlCenter
                        End With
                        If Arg_entete = True Then
                            With Excelsheet.Range(Excelsheet.cells(Arg_Ligne, Arg_Colonne), Excelsheet.cells(Arg_Ligne, Arg_Colonne + NbrChamps - 1))
                                .Interior.ColorIndex = 37
                                .Borders(xlEdgeBottom).Weight = xlMedium
                                .HorizontalAlignment = xlCenter
                                .EntireColumn.AutoFit
                            End With
                        End If
            End If
End If
 
GoTo fExportExcel_Exit
 
'gestion des erreurs
fExportExcel_Err:
    MsgBox "Une erreur inattendue est apparue dans la fonction fExportExcel. L'erreur N° " & Err.Number & " ( " & Err.Description & " )! Contactez l'administrateur.", vbOKOnly + vbCritical, "Erreur inattendue !"
    Set fExportExcel = Nothing
    Exit Function
 
'Sortie
fExportExcel_Exit:
 
    Set fExportExcel = ExcelApp
    Set ExcelApp = Nothing
    Set Excelsheet = Nothing
 
 
End Function

A+

[Puffcash]

Merci Muhad'hib,

Ton code est parfait.

Merci

[Muhad'hib]

Salut,

Je pense qu'on s'écarte un peu d'un code source ...

Ouvre un post sur le forum avec ta problématique.

Tu peux aussi m'envoyé un MP avec un lien vers ce post pour que je participe aux réponses.

A+