Discussion :

[kedmard]

Bonjour ,

Je me sers du produit suivant (programme trouvé sur la rubrique Tutoriel) pour exporter une requête vers un ficheir Excel, et cela marche très bien. Je souhaite cependant faire en sorte qu'il m'exporte 4 requêtes sur un même fichier Excel mais dans quatres onglets distincts(en les titrant éventuellement) et qu'en cas de nouvelle exportation la récente écrase l'ancienne.
Merci par avance de votre aide qui m'ait très précieusecar je bloque vraiment sur ce point depuis quelques temps.

Voici le code du tutoriel pour l'exportation:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Function TransfertExcelAutomation()
Dim xlApp As Excel.Application
Dim xlSheet As Excel.Worksheet
Dim xlBook As Excel.Workbook
Dim I As Long, J As Long
Dim t0 As Long, t1 As Long
t0 = Timer
Dim rec As Recordset
Set rec = CurrentDb.OpenRecordset("Maquette_TOP", dbOpenSnapshot)
'Initialisations
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
'Ajouter une feuille de calcul
Set xlSheet = xlBook.Worksheets.Add
xlSheet.Name = "Tutor"
 
' le titre
' écriture dans la cellule de ligne 1 et de colonne 1
xlSheet.Cells(1, 1) = "Structure des donées"
' les entetes
' .Fields(Index).Name renvoie le nom du champ
For J = 0 To rec.Fields.Count - 1
xlSheet.Cells(3, J + 1) = rec.Fields(J).Name
' Nous appliquons des enrichissements de format aux cellules
With xlSheet.Cells(3, J + 1)
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeBottom).ColorIndex = xlAutomatic
.HorizontalAlignment = xlCenter
End With
Next J
' recopie des données à partir de la ligne 3
I = 4
Do While Not rec.EOF
For J = 0 To rec.Fields.Count - 1
' .Fields(Index).Type renvoie le type du champ
' si c'est un Texte (dbText) nous insérons "'" pour
' qu'il soit reconnu par Excel comme du Texte
If rec.Fields(J).Type = dbText Then
xlSheet.Cells(I, J + 1) = "'" & rec.Fields(J)
Else
xlSheet.Cells(I, J + 1) = rec.Fields(J)
End If
Next J
I = I + 1
rec.MoveNext
Loop
 
' code de fermeture et libération des objets
xlBook.SaveAs "C:\Users\Moi\Desktop\Nouveau dossier\Export.xlsx"
xlApp.Quit
rec.Close
Set rec = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
t1 = Timer
Debug.Print I & " enregistrements", Format(t1 - t0, "0") & " secondes"
 
 
End Function

[Papy Turbo]

kedmard, bonsoir,

Je distingue 2 questions :
1- importer plusieurs requêtes au lieu d'une seule. Excellent exercice de programmation structurée
- tu crées une routine séparée, par exemple :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Private Sub ExportFeuille(xlSheet As Excel.Worksheet, Rec as  DAO.Recordset)

- tu déplaces les 2 boucles, lignes 20 à 49 dans ta nouvelle routine
- tu fais passer la ligne 9 (création du recordset) sous la 15, pour regrouper la feuille avec sa requête
- tu recopies 4 fois les lignes 14 à 19 (y compris l'ex-ligne 9), en changeant le nom de la feuille et du recordset et le contenu de la cellule (1,1),
- à chaque création de feuille, tu appelles cette nouvelle routine en lui passant à chaque fois une feuille et un recordset.
- tu gardes le reste, pour sauver / fermer le classeur et Excel proprement.
Et voilà !

2- Pour ne pas créer un classeur à chaque fois, tu peux le détruire avant (Kill "C:\Chemin\NomCLasseur.xls") et le reconstruire comme ici,
ou tu peux remplacer la commande

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Set xlBook = xlApp.Workbooks.Add

par un

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Set xlBook = xlApp.Workbooks.Open "C:\Users\Moi\Desktop\Nouveau dossier\Export.xlsx"

Mais attention au piège : si l'ancienne table comportait plus d'enregistrements que la nouvelle, il restera d'anciens enregistrements en dessous des nouveaux

[kedmard]

Bonjour, Papy Turbo
C'est drôle tu m'as repondu 1h pile poil après mon mon message....
je te remercie de l'intérêt que tu portes mon problème.

Voici ce j'ai fait en suivant tes instructions:


Pour le sous programme:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Private Sub ExportFeuille(xlSheet As Excel.Worksheet, rec As ADODB.Recordset)
'les entetes
' .Fields(Index).Name renvoie le nom du champ
For J = 0 To rec.Fields.Count - 1
xlSheet.Cells(3, J + 1) = rec.Fields(J).Name
' Nous appliquons des enrichissements de format aux cellules
With xlSheet.Cells(3, J + 1)
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeBottom).ColorIndex = xlAutomatic
.HorizontalAlignment = xlCenter
End With
Next J
' recopie des données à partir de la ligne 3
I = 4
Do While Not rec.EOF
For J = 0 To rec.Fields.Count - 1
' .Fields(Index).Type renvoie le type du champ
' si c'est un Texte (dbText) nous insérons "'" pour
' qu'il soit reconnu par Excel comme du Texte
If rec.Fields(J).Type = dbText Then
xlSheet.Cells(I, J + 1) = "'" & rec.Fields(J)
Else
xlSheet.Cells(I, J + 1) = rec.Fields(J)
End If
Next J
I = I + 1
rec.MoveNext
Loop
 
End Sub

Et le programme principale:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Function TransfertExcelAutomation1()
Dim xlApp As Excel.Application
Dim xlSheet As Excel.Worksheet
Dim xlBook As Excel.Workbook
Dim I As Long, J As Long
Dim t0 As Long, t1 As Long
t0 = Timer
Dim rec1, rec2, rec3, rec4 As Recordset
 
'Initialisations
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
'Ajouter une feuille de calcul
   Set xlSheet = xlBook.Worksheets.Add
   xlSheet.Name = "Tutor1"
   Set rec1 = CurrentDb.OpenRecordset("Maquette_TOP", dbOpenSnapshot)
   ' le titre1
   ' écriture dans la cellule de ligne 1 et de colonne 1
   xlSheet.Cells(1, 1) = "Première Structure des donées"
   '''''''''''''''''
   '''''''''''''''''
             Set xlSheet = xlBook.Worksheets.Add
             xlSheet.Name = "Tutor2"
             Set rec2 = CurrentDb.OpenRecordset("Dossiers_Technique", dbOpenSnapshot)
   ' le titre2
   ' écriture dans la cellule de ligne 1 et de colonne 1
             xlSheet.Cells(1, 1) = "Deuxième Structure des donées"
   '''''''''''''''''
                 Set xlSheet = xlBook.Worksheets.Add
                 xlSheet.Name = "Tutor3"
                 Set rec3 = CurrentDb.OpenRecordset("Nombre_RC", dbOpenSnapshot)
   ' le titre3
   ' écriture dans la cellule de ligne 1 et de colonne 1
                 xlSheet.Cells(1, 1) = " Troisième Structure des donées"
   '''''''''''''''''
                    Set xlSheet = xlBook.Worksheets.Add
                    xlSheet.Name = "Tutor4"
                    Set rec4 = CurrentDb.OpenRecordset("Dossiers_ARP", dbOpenSnapshot)
   ' le titre4
   ' écriture dans la cellule de ligne 1 et de colonne 1
                    xlSheet.Cells(1, 1) = "Quatrième Structure des donées"
   '''''''''''''''''
   ''''''''''''''''''
Call ExportFeuille(Tutor1, rec1)
Call ExportFeuille(Tutor2, rec2)
Call ExportFeuille(Tutor3, rec3)
Call ExportFeuille(Tutor4, rec4)
 
' code de fermeture et libération des objets
xlBook.SaveAs "C:\Users\Moi\Desktop\Nouveau dossier\Export.xlsx"
xlApp.Quit
rec.Close
Set rec = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
t1 = Timer
Debug.Print I & " enregistrements", Format(t1 - t0, "0") & " secondes"
 
 
End Function

Au finish j'ai l'erreur suivant


Erreur de Compiltion :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Type d'argument ByRef incompatible

et cela au niveau des Call pour les arguments Tutor1, ... Tutor4




Merci

[Papy Turbo]

Bonjour, kedmard,

Ou, pour éviter toute erreur de "Type d'argument", devrais-je plutôt dire :

Bonjour, la personne qui s'appelle "kedmard" ?

[kedmard]

J'ai remplacé par ceci:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Call ExportFeuille(xlSheet1, rec1)
Call ExportFeuille(xlSheet2, rec2)
Call ExportFeuille(xlSheet3, rec3)
Call ExportFeuille(xlSheet4, rec4)

et j'ai toujours la même erreur.

[kedmard]

ça y est ça marche,
Merci Papy Turbo il suffisait de préciser à la fin
rec1.close
rec2.close
....
Cependant, je suis un peu dessus car , je croyais pouvoir créer dans d'autres feuilles des tableaux croisés dynamiques se servant des données exportées et ce de façon automatique, c-à-d dès que les donnée exportées arrivent sur leur onglet respespectif , les tableaux croisés dynamiques contenus dans les autres onglets s'alimentent automatiquement.

Mais je clos quand même cette discussion pour en ouvrir une autre.

Merci encore Papy Turbo.

[Papy Turbo]

Bravo.
Juste une petite remarque avant de fermer, par rapport à ce code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Call ExportFeuille(xlSheet1, rec1)
Call ExportFeuille(xlSheet2, rec2)
Call ExportFeuille(xlSheet3, rec3)
Call ExportFeuille(xlSheet4, rec4)

Je constate, plus haut, que tu n'utilises en fait qu'un seul objet xlSheet : bien.
Mais pourquoi utiliser 4 variables rec1 à rec4 ?
Une seule "rec" suffit, auquel tu réaffectes chacun des 4 recordsets, et que tu passes 4 fois avec un contenu différent.
Il n'y en aura qu'un a vider à la fin.

[kedmard]

sur mon code j'en ai fait 4 et ça marche.
Avec un seul j'avais un message d'erreur.

[Papy Turbo]

Lequel ?

[ezequielfranck]

Bonjour Kerband,

peux tu faire un copier coller de code qui marche ici STP ?
parceque chez moi cela ne fonctionne pas malgré vos suggestions.

Merci d'avance!

[patgame]

ça y est ça marche,
Merci Papy Turbo il suffisait de préciser à la fin
rec1.close
rec2.close
....
Cependant, je suis un peu dessus car , je croyais pouvoir créer dans d'autres feuilles des tableaux croisés dynamiques se servant des données exportées et ce de façon automatique, c-à-d dès que les donnée exportées arrivent sur leur onglet respespectif , les tableaux croisés dynamiques contenus dans les autres onglets s'alimentent automatiquement.

Mais je clos quand même cette discussion pour en ouvrir une autre.

Merci encore Papy Turbo.

peux tu poster le code complet en une seule fois je suis interessé par cet export de plusieurs requetes avec la mise a jour moi j'ai plus de 4 requetes (5 en fait) mais j'adapterais

et comment fait on on fait une procedure evenementielle ?

merci a toi

Cdlt

Pat

[Papy Turbo]

Bon ben, il semble que kedmard ne réponde plus, donc voici une version complète du code qui devrait fonctionner sans trop de problème.
Non testée et sans contrôle d'erreur : à tester en pas à pas, vérifier si les recordsets ne sont pas vides...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Compare Database
Option Explicit
 
Function TransfertExcelAutomation1()
Dim xlApp           As Excel.Application
Dim xlSheet         As Excel.Worksheet
Dim xlBook          As Excel.Workbook
Dim t0 As Single
Dim rec As DAO.Recordset
 
    t0 = Timer
    'Initialisations
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add
    'Ajouter une feuille de calcul
    Set xlSheet = xlBook.Worksheets.Add
    xlSheet.Name = "Tutor1"
    Set rec = CurrentDb.OpenRecordset("Maquette_TOP", dbOpenSnapshot)
    ' le titre1
    ' écriture dans la cellule de ligne 1 et de colonne 1
    xlSheet.Cells(1, 1) = "Première Structure des donées"
    ExportFeuille xlSheet, rec
    '''''''''''''''''
    '''''''''''''''''
    Set xlSheet = xlBook.Worksheets.Add
    xlSheet.Name = "Tutor2"
    Set rec = CurrentDb.OpenRecordset("Dossiers_Technique", dbOpenSnapshot)
    ' le titre2
    ' écriture dans la cellule de ligne 1 et de colonne 1
    xlSheet.Cells(1, 1) = "Deuxième Structure des donées"
    ExportFeuille xlSheet, rec
    '''''''''''''''''
    Set xlSheet = xlBook.Worksheets.Add
    xlSheet.Name = "Tutor3"
    Set rec = CurrentDb.OpenRecordset("Nombre_RC", dbOpenSnapshot)
    ' le titre3
    ' écriture dans la cellule de ligne 1 et de colonne 1
    xlSheet.Cells(1, 1) = " Troisième Structure des donées"
    ExportFeuille xlSheet, rec
    '''''''''''''''''
    Set xlSheet = xlBook.Worksheets.Add
    xlSheet.Name = "Tutor4"
    Set rec = CurrentDb.OpenRecordset("Dossiers_ARP", dbOpenSnapshot)
    ' le titre4
    ' écriture dans la cellule de ligne 1 et de colonne 1
    xlSheet.Cells(1, 1) = "Quatrième Structure des donées"
    ExportFeuille xlSheet, rec
    '''''''''''''''''
    ''''''''''''''''''
 
    ' code de fermeture et libération des objets
    xlBook.SaveAs "C:\Users\Moi\Desktop\Nouveau dossier\Export.xlsx"
    xlBook.Close False
    rec.Close
    Set rec = Nothing
    Set xlSheet = Nothing
    Set xlBook = Nothing
    xlApp.Quit
    Set xlApp = Nothing
    Debug.Print "Export complet en ", Format(Timer - t0, "0") & " secondes"
End Function
 
 
Private Sub ExportFeuille(xlSheet As Excel.Worksheet, rec As ADODB.Recordset)
Dim FieldPointer As Long
Dim RowPointer As Long
 
    'les entetes
    ' .Fields(Index).Name renvoie le nom du champ
    For FieldPointer = 0 To rec.Fields.Count - 1
        With xlSheet.Cells(3, FieldPointer + 1)
            .Value = rec.Fields(FieldPointer).Name
            ' Nous appliquons des enrichissements de format aux cellules
            .Interior.ColorIndex = 15
            .Interior.Pattern = xlSolid
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            .HorizontalAlignment = xlCenter
        End With
    Next FieldPointer
    ' recopie des données à partir de la ligne 3
    RowPointer = 4
    rec.MoveFirst
    Do While Not rec.EOF
        For FieldPointer = 0 To rec.Fields.Count - 1
            ' .Fields(Index).Type renvoie le type du champ
            ' si c'est un Texte (dbText) nous insérons "'" pour
            ' qu'il soit reconnu par Excel comme du Texte
            If rec.Fields(FieldPointer).Type = dbText Then
                xlSheet.Cells(RowPointer, FieldPointer + 1) = "'" & rec.Fields(FieldPointer)
            Else
                xlSheet.Cells(RowPointer, FieldPointer + 1) = rec.Fields(FieldPointer)
            End If
        Next FieldPointer
        RowPointer = RowPointer + 1
        rec.MoveNext
    Loop
 
End Sub

[Salo15]

Bonjour,

Je suis dans la même situation et je pense que le code que vous suggérez peut m'être très utile, seul problème, l'informatique n'est pas mon domaine et je ne sais pas du tout où je dois aller coller le code pour le modifier et l'adapter à ma BDD de thèse. Désolée pour cette question bête, j'ai cherché partout mais je n'ai pas trouvé.
Merci par avance

[hyperion13]

Salut
Vous devez créer un module dans l'environnement vba d'Access (Alt F11) puis copier, adapter les éléments de la fonction.

[lacsaphumble2012]

Bon ben, il semble que kedmard ne réponde plus, donc voici une version complète du code qui devrait fonctionner sans trop de problème.
Non testée et sans contrôle d'erreur : à tester en pas à pas, vérifier si les recordsets ne sont pas vides...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Compare Database
Option Explicit
 
Function TransfertExcelAutomation1()
Dim xlApp           As Excel.Application
Dim xlSheet         As Excel.Worksheet
Dim xlBook          As Excel.Workbook
Dim t0 As Single
Dim rec As DAO.Recordset
 
    t0 = Timer
    'Initialisations
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add
    'Ajouter une feuille de calcul
    Set xlSheet = xlBook.Worksheets.Add
    xlSheet.Name = "Tutor1"
    Set rec = CurrentDb.OpenRecordset("Maquette_TOP", dbOpenSnapshot)
    ' le titre1
    ' écriture dans la cellule de ligne 1 et de colonne 1
    xlSheet.Cells(1, 1) = "Première Structure des donées"
    ExportFeuille xlSheet, rec
    '''''''''''''''''
    '''''''''''''''''
    Set xlSheet = xlBook.Worksheets.Add
    xlSheet.Name = "Tutor2"
    Set rec = CurrentDb.OpenRecordset("Dossiers_Technique", dbOpenSnapshot)
    ' le titre2
    ' écriture dans la cellule de ligne 1 et de colonne 1
    xlSheet.Cells(1, 1) = "Deuxième Structure des donées"
    ExportFeuille xlSheet, rec
    '''''''''''''''''
    Set xlSheet = xlBook.Worksheets.Add
    xlSheet.Name = "Tutor3"
    Set rec = CurrentDb.OpenRecordset("Nombre_RC", dbOpenSnapshot)
    ' le titre3
    ' écriture dans la cellule de ligne 1 et de colonne 1
    xlSheet.Cells(1, 1) = " Troisième Structure des donées"
    ExportFeuille xlSheet, rec
    '''''''''''''''''
    Set xlSheet = xlBook.Worksheets.Add
    xlSheet.Name = "Tutor4"
    Set rec = CurrentDb.OpenRecordset("Dossiers_ARP", dbOpenSnapshot)
    ' le titre4
    ' écriture dans la cellule de ligne 1 et de colonne 1
    xlSheet.Cells(1, 1) = "Quatrième Structure des donées"
    ExportFeuille xlSheet, rec
    '''''''''''''''''
    ''''''''''''''''''
 
    ' code de fermeture et libération des objets
    xlBook.SaveAs "C:\Users\Moi\Desktop\Nouveau dossier\Export.xlsx"
    xlBook.Close False
    rec.Close
    Set rec = Nothing
    Set xlSheet = Nothing
    Set xlBook = Nothing
    xlApp.Quit
    Set xlApp = Nothing
    Debug.Print "Export complet en ", Format(Timer - t0, "0") & " secondes"
End Function
 
 
Private Sub ExportFeuille(xlSheet As Excel.Worksheet, rec As ADODB.Recordset)
Dim FieldPointer As Long
Dim RowPointer As Long
 
    'les entetes
    ' .Fields(Index).Name renvoie le nom du champ
    For FieldPointer = 0 To rec.Fields.Count - 1
        With xlSheet.Cells(3, FieldPointer + 1)
            .Value = rec.Fields(FieldPointer).Name
            ' Nous appliquons des enrichissements de format aux cellules
            .Interior.ColorIndex = 15
            .Interior.Pattern = xlSolid
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            .HorizontalAlignment = xlCenter
        End With
    Next FieldPointer
    ' recopie des données à partir de la ligne 3
    RowPointer = 4
    rec.MoveFirst
    Do While Not rec.EOF
        For FieldPointer = 0 To rec.Fields.Count - 1
            ' .Fields(Index).Type renvoie le type du champ
            ' si c'est un Texte (dbText) nous insérons "'" pour
            ' qu'il soit reconnu par Excel comme du Texte
            If rec.Fields(FieldPointer).Type = dbText Then
                xlSheet.Cells(RowPointer, FieldPointer + 1) = "'" & rec.Fields(FieldPointer)
            Else
                xlSheet.Cells(RowPointer, FieldPointer + 1) = rec.Fields(FieldPointer)
            End If
        Next FieldPointer
        RowPointer = RowPointer + 1
        rec.MoveNext
    Loop
 
End Sub

Bonsoir au groupe,
Dans mes recherches je suis tombé sur ce code, mais en testant il me renvoie un message d'erreur incompatibilité de type et sélectionne ExportFeuille. quelqu'un aurait une solution. merci bonne soirée

[hyperion13]

Salut
Probablement un problème de déclaration entre L9 et L64 du code.

[lacsaphumble2012]

Salut
Probablement un problème de déclaration entre L9 et L64 du code.

Bonsoir,
effectivement, comment y remédie ? j'ai besoin exporté 28 requêtes dans un même classeur sur des feuilles différentes. merci

[hyperion13]

Euh ...
Peut-être lire le Post#2

Bonsoir,
effectivement, comment y remédie ?

Un peu de lecture ici et là