Plusieurs problèmes sur export requête vers Excel

Version imprimable

Bonjour à tous,
J'ai plusieurs problèmes liés au lignes de codes ci-dessous.
J'ai glané et adapté ce code à mon projet.
L'export fonctionne super, ouverture d'Excel et export du contenu des requêtes.
Sauf que...
Je ne sais pas pourquoi mais
- lorsque j'ouvre le fichier Excel j'ai plein de nouvelles feuilles (Feuil1, Feuil2,Feuil3...) et si je "re click" sur le bouton il me "re-crée" de nouvelles feuilles jusqu'à Feuil22, Feuil23... ???
- Les en-têtes des requêtes ont disparues ??
- Deux requêtes qui contenaient des datas, quand elles sont exportées dans une feuille, les cellules sont vides... dois-je lancer ces requêtes avant l'export (il y a une sélection "entre 2 dates") ???

Code:

1
2
3
4
5
6
7
Private Function FeuilleExiste(ByVal sNom As String) As Boolean
Dim Ws As Worksheet
    On Error Resume Next
    Set Ws = Worksheets(sNom)
    If Err.Number <> 0 Then FeuilleExiste = False Else FeuilleExiste = True
 
End Function

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
121
122
123
124
125
126
127
 
Sub ExportExcel()
 
Dim dbs As DAO.Database
Dim xlWB As Excel.Workbook 'Est un classeur
 
Set dbs = CurrentDb
Set xlApp = CreateObject("Excel.application", "")
 
'adresse d'export pré-saisie dans la tableT000_RequestExportLink
FichierXl = DLookup("LinkForRequestExport", "T000_RequestExportLink", "N°=1")
fileName = Dir(FichierXl & "*.XLSX", vbDirectory)
 
 
'ouverture de excel, une fois pour tous les autes cas
xlApp.Visible = True
 
    '******************ouverture requete1**********************************************************************************
Set rst = dbs.OpenRecordset("R0001")
'pointer le fichier excel - le faire une fois pour toutes les requetes
Set targetWorkbook = xlApp.Workbooks.Open(FichierXl & fileName, True, False)
 
'Creation de la feuille si elle n'existe pas dans le fichier excel
        On Error Resume Next
        Worksheets(R0001).Select
        If Err <> 0 Then Worksheets.Add.Name = "R0000_LogisticCosts_PerYear"
'colle les infos dans la cellule de départ
targetWorkbook.Worksheets("R0001").Range("a1").CopyFromRecordset rst
'Suivante....
 
    '******************ouverture requete2**********************************************************************************
            Set rst = dbs.OpenRecordset("R0002")
'Set targetWorkbook = xlApp.Workbooks.Open(FichierXl & fileName, True, False)
 
            'Creation de la feuille si elle n'existe pas dans le fichier excel
                    On Error Resume Next
                    Worksheets(R0002).Select
                    If Err <> 0 Then Worksheets.Add.Name = "R0002"
            'colle les infos dans la cellule de départ
            targetWorkbook.Worksheets("R0002").Range("a1").CopyFromRecordset rst
            'Suivante....
 
    '******************ouverture requete3**********************************************************************************
            Set rst = dbs.OpenRecordset("R0003")
'Set targetWorkbook = xlApp.Workbooks.Open(FichierXl & fileName, True, False)
 
            'Creation de la feuille si elle n'existe pas dans le fichier excel
                    On Error Resume Next
                    Worksheets(R0003).Select
                    If Err <> 0 Then Worksheets.Add.Name = "R0003"
            'colle les infos dans la cellule de départ
            targetWorkbook.Worksheets("R0003").Range("a1").CopyFromRecordset rst
            'Suivante....
 
    '******************ouverture requete4**********************************************************************************
            Set rst = dbs.OpenRecordset("R0004")
'Set targetWorkbook = xlApp.Workbooks.Open(FichierXl & fileName, True, False)
 
            'Creation de la feuille si elle n'existe pas dans le fichier excel
                    On Error Resume Next
                    Worksheets(R0004).Select
                    If Err <> 0 Then Worksheets.Add.Name = "R0004"
            'colle les infos dans la cellule de départ
            targetWorkbook.Worksheets("R0004").Range("a1").CopyFromRecordset rst
            'Suivante....
 
 
    '******************ouverture requete5**********************************************************************************
            Set rst = dbs.OpenRecordset("R0005")
'Set targetWorkbook = xlApp.Workbooks.Open(FichierXl & fileName, True, False)
 
            'Creation de la feuille si elle n'existe pas dans le fichier excel
                    On Error Resume Next
                    Worksheets(R0005).Select
                    If Err <> 0 Then Worksheets.Add.Name = "R0005"
            'colle les infos dans la cellule de départ
            targetWorkbook.Worksheets("R0005").Range("a1").CopyFromRecordset rst
            'Suivante....
 
    '******************ouverture requete6**********************************************************************************
            Set rst = dbs.OpenRecordset("R0006")
'Set targetWorkbook = xlApp.Workbooks.Open(FichierXl & fileName, True, False)
 
            'Creation de la feuille si elle n'existe pas dans le fichier excel
                    On Error Resume Next
                    Worksheets(R0006).Select
                    If Err <> 0 Then Worksheets.Add.Name = "R0006"
            'colle les infos dans la cellule de départ
            targetWorkbook.Worksheets("R0006").Range("a1").CopyFromRecordset rst
            'Suivante....
 
    '******************ouverture requete7**********************************************************************************
            Set rst = dbs.OpenRecordset("R0007")
'Set targetWorkbook = xlApp.Workbooks.Open(FichierXl & fileName, True, False)
 
            'Creation de la feuille si elle n'existe pas dans le fichier excel
                    On Error Resume Next
                    Worksheets(R0007).Select
                    If Err <> 0 Then Worksheets.Add.Name = "R0007"
            'colle les infos dans la cellule de départ
            targetWorkbook.Worksheets("R0007").Range("a1").CopyFromRecordset rst
            'Suivante....
 
    '******************ouverture requete8**********************************************************************************
            Set rst = dbs.OpenRecordset("R0008")
'Set targetWorkbook = xlApp.Workbooks.Open(FichierXl & fileName, True, False)
 
            'Creation de la feuille si elle n'existe pas dans le fichier excel
                    On Error Resume Next
                    Worksheets(R0008).Select
                    If Err <> 0 Then Worksheets.Add.Name = "R0008"
            'colle les infos dans la cellule de départ
            targetWorkbook.Worksheets("R0008").Range("a1").CopyFromRecordset rst
            'Suivante....
 
 
 
xlApp.DisplayAlerts = False
targetWorkbook.Close True 'en mettant true tu enregistres en fermant (false si tu ne veux pas le faire)
xlApp.Visible = False
xlApp.Quit
Set xlApp = Nothing
 
 
MsgBox "Export done !"
 
End Sub

Si quelqu'un a des idées ...
Je suis preneur.
Un grand merci d'avance
Totor

Salut,

Tes verification de l'existance des feuilles, c'est bancal.

Je te propose une fonction utilitaire, qui donneras plus de sens à ton code et moins de prise de tête avec les gestionnaire d'erreur:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Public Function ExistInCollection(ByVal Key As String, ByRef Col As Object) As Boolean
	ExistInCollection = ExistInCollectionByValByVal(Key, Col) Or ExistInCollectionByRef(Key, Col)
End Function
 
Private Function ExistInCollectionByValByVal Key As String, ByRef Col As Object) As boolean
On Error Goto Error
	Dim Item As Variant
	Item = col(Key)
	ExistInCollectionByValByVal = True
Exit Function
Error:
	ExistInCollectionByValByVal = False
End Function
 
Private Function ExistInCollectionByRef(ByVal Key As String, ByRef Col As Object) As Boolean
On Error Goto Error
	Dim Item As Variant
	Set Item = col(Key)
	ExistInCollectionByRef = True
Exit Function
Error:
	ExistInCollectionByRef = False
End Function

Exemple d'utilisation:

Code:

1
2
3
4
5
6
Sub Test()
    If Not ExistIncollection("MaFeuille", ThisWorkbook.Worksheets) Then
        MsgBox("La feuille n'existe pas").
        Exit Sub
    End If
End Sub

01/06/2023, 14h11
totor92290
Ouahhh...
Merci mais le problème c'est que j'ai copié/collé des lignes de code pour obtenir mon code et qui semble fonctionné excepté les problèmes décrit plus haut.
Là avec ce que tu me proposes, étant débutant, il va falloir que je revois tout ... non ?
Comment, dans ce code on informe de l'emplacement du fichier excel et des feuilles associées ?
De plus j'ai un message d'erreur (dû fait que je n'ai pas adapté le code sans doute)
"erreur d'execution 1004: la méthode "thisworkbook" de l'objet '_Global' a échoué"
Code:

1 2 3 4 5 6 Sub Test() If Not ExistInCollection("R0001", ThisWorkbook.Worksheets) Then MsgBox ("La feuille n'existe pas") Exit Sub End If End Sub
Beaucoup de questions...

Merci
Totor
01/06/2023, 14h36
deedolith

Quand on est débutant,
l'erreur à ne pas faire, c'est de copier / coller sans comprendre.

Il va certainnement falloir que tu reprenne ton code à partir de zero ou presque, d'ailleur j'airemarqué que tu exporte plusieurs requête, le code etant similaire, tu peux factoriser.
N'hesite pas à ecrire de petites fonction afin de te faciliter la vie, et respecter le SRP ainsi que la Loi de demeter.
Je peux te garantir que le mise en oeuvre de ces deux principes va grandement améliorer la qualité de ton code.

Liens:
SRP: https://en.wikipedia.org/wiki/Single...lity_principle
Loi de Demeter: https://fr.wikipedia.org/wiki/Loi_de_D%C3%A9m%C3%A9ter
01/06/2023, 15h29
totor92290

Bonjour deedolith,
En fait je ne suis pas développeur, et je n'ai pas vocation à le devenir.
Je travaille dans une entreprise dans des fonctions opérationnelles.
Mon approche est la suivante, développez des petites appli sous format Proof Of Concept pour faciliter la vie des opérationnels.
Ensuite quand l'appli a suffisamment "tournée" et a été adaptée aux différents besoins -amendée- je la présente à ma hiérarchie.
Si ma hiérarchie valide et considère le gain et donc le budget, je me tourne vers un développeur pro, qui lui, reprend et corrige mes "espèces de codes" -souvent ça les fait marrer !- et qui assure la maintenance.
Voilà en fait pourquoi ça "patachone" du côté de mes codes.
Voili, voilà...
Si toutefois tu pouvais me dire pourquoi les en-têtes des requêtes n'apparaissent pas dans mes feuilles excel ???
Pour les feuilles qui se créent en plus, je vais me débrouiller avec du Feuil1.delete

D'avance merci
Olivier

Citation:

Envoyé par totor92290

... Si toutefois tu pouvais me dire pourquoi les en-têtes des requêtes n'apparaissent pas dans mes feuilles excel ???

Salut
Post#1 2ème code ligne 28. tu copies à partir de "A1" alors qu'il faudrait que ce soit "A2".
La méthode CopyFromRecordset rst,ne recopie pas les en-têtes du recordset. Étonnant qu'on ne t'ait pas fait la remarque.
Sinon solution
Tu adaptes les lignes 41 à 46 avec tes lignes 10 à 12

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
121
122
123
124
125
126
127
128
129
130
131
Option Explicit
Public Function FeuilleExiste(xlWbk As Excel.Workbook, strSheetName As String) As Boolean
Dim xlWsh As Excel.Worksheet
 
On Error Resume Next
Set xlWsh = xlWbk.Worksheets(strSheetName)
If Err <> 0 Then
    FeuilleExiste = False
Else
    FeuilleExiste = True
End If
On Error GoTo 0
End Function
 
Public Function ExtractFileName(ByVal FilePath As String) As String
    ExtractFileName = Mid(FilePath, InStrRev(FilePath, "\") + 1)
End Function
 
Private Sub btnExportXL_Click()
'https://excel.developpez.com/actu/296176/Piloter-Excel-depuis-Access-apprendre-les-bonnes-pratiques-un-billet-de-blog-de-Denis-Hulo/
On Error GoTo err_ExportData
#Const EarlyBind = True ' Nécessite Microsoft Excel xx.x Object Library
#If EarlyBind = True Then
    'Early Binding
    Dim xlApp As Excel.Application
    Dim xlWbk As Excel.Workbook
    Dim xlWsh As Excel.Worksheet
#Else
    'Late Binding
    Dim xlApp As Object
    Dim xlWbk As Object
    Dim xlWsh As Object
#End If
Dim bExcelOpened As Boolean
 
Dim dbs As DAO.Database, qdf As DAO.QueryDef, rst As DAO.Recordset
Dim strFolderPath As String, strBackSlash As String, strFileName As String, strExt As String, strFilePath As String, strSheetName As String
Dim i As Long, j As Long
Dim result As Boolean
 
strFolderPath = CurrentProject.Path
strBackSlash = "\"
strFileName = "20230601_totor92290"
strExt = ".xlsx"
 
strFilePath = strFolderPath & strBackSlash & strFileName & strExt
 
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
On Error GoTo err_ExportData
 
If xlApp Is Nothing Then
    Set xlApp = CreateObject("Excel.Application")
End If
 
On Error Resume Next
Set xlWbk = xlApp.Workbooks.Item(ExtractFileName(strFilePath))
On Error GoTo err_ExportData
 
If xlWbk Is Nothing Then
    Set xlWbk = xlApp.Workbooks.Open(strFilePath)
End If
 
Set dbs = CurrentDb
 
For Each qdf In dbs.QueryDefs
    If qdf.Name Like "R000*" Then ' on cherche les qry qui commencet par "R000"
        Set rst = dbs.OpenRecordset(qdf.Name)
        strSheetName = qdf.Name
        result = FeuilleExiste(xlWbk, strSheetName)
            If result = True Then
                With xlWbk.Worksheets(strSheetName)
                    For i = 1 To rst.Fields.Count
                        .Cells(1, i).Value = rst.Fields(i - 1).Name ' copie des en-tête ligne 1
                    Next i
                    .Range("A2").CopyFromRecordset rst ' copie des données ligne 2
                    .Cells.EntireColumn.AutoFit ' ajustement largeur colonnes
                End With
            Else
                Worksheets.Add.Name = strSheetName
                With xlWbk.Worksheets(strSheetName)
                    For i = 1 To rst.Fields.Count
                        .Cells(1, i).Value = rst.Fields(i - 1).Name
                    Next i
                    .Range("A2").CopyFromRecordset rst
                    .Cells.EntireColumn.AutoFit
                End With
            End If
        rst.Close
    End If
Next qdf
 
result = FeuilleExiste(xlWbk, "R0000_LogisticCosts_PerYear")
If result = False Then
    Worksheets.Add.Name = "R0000_LogisticCosts_PerYear"
End If
 
For i = 1 To Worksheets.Count - 1 ' tri ordre croissant des feuilles
    For j = i + 1 To Worksheets.Count
        If UCase(Worksheets(j).Name) < UCase(Worksheets(i).Name) Then
            Worksheets(j).Move before:=Worksheets(i)
        End If
    Next j
Next i
 
For Each xlWsh In xlWbk.Worksheets
    If xlWsh.Name = "Feuil1" Then
        Worksheets("Feuil1").Delete
    End If
Next
 
err_ExportData:
If Err.Number <> 0 Then
    MsgBox "Une erreur est survenue" & vbCrLf & vbCrLf & _
           "Numéro erreur : " & Err.Number & vbCrLf & vbCrLf & _
           "Description erreur : " & Err.Description
End If
 
On Error Resume Next
If Not (rst Is Nothing) Then
    rst.Close
End If
 
Set rst = Nothing
Set dbs = Nothing
Set xlWsh = Nothing
xlWbk.Close True
Set xlWbk = Nothing
xlApp.Quit
Set xlApp = Nothing
End Sub