Discussion :

[kabamel]

Salus à tous.
J'ai un problème d'export en excel
J'ai deux requete que je voudrais envoyé en excel par automation ci-joint une base exemple et un fichier excel
je mets aussi le code que j'ai, dont je veux modifier.
Voici le code :

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
103
104
105
Function TransfertBulletinVersExcel()
 
'Déclaration
Dim xlApp As Excel.Application
Dim xlSheet As Excel.Workbook
Dim xlBook As Excel.Workbook
Dim I As Long, J As Long
Dim t0 As Long, t1 As Long
Dim db As Database, rst As Recordset, rec As Recordset, fld As DAO.Field
Dim CheminBulletin As String 'Est le chemin du fichier Exemple
Dim CheminACreer As String   'Est le chemin du Nouveau fichier
Dim sSQL As String, sSQL0 As String
CheminACreer = CurrentProject.path & "\" & Year(Now) & Month(Now) & Day(Now) & ".xlsm"
 
t0 = Timer       'Définition de temps initial
 
' Ouverture de la base de données
    Set db = CurrentDb
        sSQL = "SELECT Rqt_Rang.Numéro_Elève, Rqt_Rang.Matricule, tbl_Elèves.Nom_Elève, tbl_Elèves.Prénom_Elève, tbl_Elèves.Chemin_Photo, Rqt_Rang.Nom_Classe, Rqt_Rang.N°Evaluation, Rqt_Rang.Moyenne, Rqt_Rang.Rang, Rqt_Rang.Appreciation " & _
                    "FROM Rqt_Rang INNER JOIN tbl_Elèves ON Rqt_Rang.Numéro_Elève = tbl_Elèves.Numéro_Elève " & _
                    "WHERE (((Rqt_Rang.Numéro_Elève)=[txtMatriculeExport]), ((Rqt_Rang.N°Evaluation)=[txtTrimestreExport])); "
 
        sSQL0 = "SELECT Rqt_prébulletin.Numéro_Elève, Rqt_prébulletin.Numéro_Matière, Rqt_prébulletin.Coefficient, Rqt_prébulletin.MinDeNote, Rqt_prébulletin.Note, Rqt_prébulletin.MaxDeNote " & _
                    "FROM Rqt_prébulletin " & _
                    "WHERE (((Rqt_prébulletin.Numéro_Elève)=[txtMatriculeExport]), ((Rqt_prébulletin.N°Evaluation)=[txtTrimestreExport])); "
 
    ' Ouverture du Recordset
        Set rst = db.OpenRecordset(sSQL, dbOpenSnapshot)
        Set rec = CurrentDb.OpenRecordset("sSQL0", dbOpenSnapshot)
 
'Appel du fichier Excel :
        Set xlApp = CreateObject("Excel.Application")
        xlApp.visible = True
 
        'Vérification si fichier existe
        If Dir(CheminBulletin) <> "" Then
            Set xlSheet = xlApp.Workbooks.Open(CheminBulletin)
 
            'Appel de la feuille correspondante :
                xlApp.Sheets("NomFeuil").Select
 
            'Remplissage dans Excel (exemple à partir de la première requête), sur des cellules bien précises.
                'Attention la cellule (5,2) correspond à la cellule B5 d'Excel.
                'La fonction rst correspond à un enregistrement Recordset.
 
                xlApp.Cells(5, 2) = rst![Nomduchamp]
                xlApp.Cells(5, 4) = rst![Nomduchamp]
                xlApp.Cells(5, 7) = rst![Nomduchamp]
 
        'Appel à la deuxième requête
 
          ' les entetes
    '  .Fields(Index).Name renvoie le nom du champ
    For J = 0 To rec.Fields.Count - 1
        xlApp.Cells(2, J + 1) = rec.Fields(J).Name
        ' Nous appliquons des enrichissements de format aux cellules
        With xlApp.Cells(2, 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 = 3
    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
                xlApp.Cells(I, J + 1) = "'" & rec.Fields(J)
            Else
                xlApp.Cells(I, J + 1) = rec.Fields(J)
            End If
        Next J
        I = I + 1
        rec.MoveNext
    Loop
 
 
        Else
            MsgBox "Le chemin du fichier est introuvable !", vbCritical + vbOKOnly, "Chemin Introuvable"
        End If
 
     ' code de fermeture et libération des objets
    xlBook.SaveAs CheminACreer
    'xlBook.SaveAs "D:\Feuille.xlsx"
    xlApp.Quit
    rst.Close    ' Fermeture de la Premiere requête
    rec.Close    ' Fermeture de la Deuxième requête
    Set rec = Nothing
    Set rst = Nothing
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
 
    t1 = Timer
    'Debug.Print I & " enregistrements", Format(t1 - t0, "0") & " secondes"
    MsgBox "Vous avez copié " & I & " enregistrements en " & Format(t1 - t0, "0") & " secondes", vbInformation, "Fichier envoyé avec succès"
 
End Function

Voici la base exemple. Pour plus d'info n'hésité pas. Merci pour votre aide