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
|
Function ExportExcel(MyReq As String, MyFile As String)
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim xlApp As Excel.Application
Dim xlSheet As Excel.Worksheet
Dim xlBook As Excel.Workbook
Dim LeLibelle As String
Dim PrefixeGroupe As String
Set db = CurrentDb
Set rst = db.OpenRecordset(MyReq, dbOpenSnapshot)
If rst.RecordCount < 1 Then 'test si requete vide sinon plantage au rst.movefirst
Call Affiche("Pas d'enregistrement répondant aux critères", 1)
Set rst = Nothing
Set db = Nothing
Exit Function
End If
rst.MoveFirst 'on se place au premier enregistrement
Do
PrefixeGroupe = rst.Fields(0) 'on affecte le nom du champ O a la variable (soit le nom du groupe)
Set xlApp = CreateObject("Excel.Application") ' on ouvre l'application Excel en invisible
'xlApp.Visible = True 'Pour test : rendre Excel visible
Set xlBook = xlApp.Workbooks.Add ' on crée un nouveau fichier
Do
Set xlSheet = xlBook.Worksheets.Add 'on ajoute un onglet dans excel
xlSheet.Name = Left(rst.Fields(1) & " " & rst.Fields(2), 31) ' l'onglet s'appelle du nom du premier champ et du 2d : ent + libelle
' Onglet Excel pas plus de 31 caractères
For j = 1 To rst.Fields.Count - 1 ' on parcourt tous les champs sauf le (0) et on met le nom en première ligne
xlSheet.Cells(1, j) = rst.Fields(j).Name
With xlSheet.Cells(1, j) 'quelques mises en forme
.Interior.ColorIndex = 15 'couleur à gris
.Interior.Pattern = xlSolid 'fond de cellule à gris
.HorizontalAlignment = xlCenter 'centrage du titre
End With
Next j
i = 2 'on place l'index sur la 2d ligne pour remplir les données
Do 'on fait ce qui suit tant que le champ1+2 est égal à l'onglet
For z = 1 To rst.Fields.Count - 1 'on parcourt à nouveau chaque champ sauf le premier 0
xlSheet.Cells(i, z) = rst.Fields(z) ' on remplit les cellules avec les données
Next z
i = i + 1 'index sur ligne suivant
rst.MoveNext 'on passe à l'enregistrement suivant dans la requete
If rst.EOF Then Exit Do ' si jamais c'est la fin du fichier, on sort de la boucle
LeLibelle = Left(rst.Fields(1) & " " & rst.Fields(2), 31) ' après le movenext : on reaffecte champ1+champ2 a la variable Libelle
Loop While LeLibelle = xlSheet.Name 'on fait ça tant que le premier champ = onglet, sinon on change d'onglet
xlSheet.Columns.AutoFit 'on adapte la largeur des colonnes au contenu
If rst.EOF Then Exit Do 'si jamais c'est fin de fichier : on sort de la boucle pour pas planter
Loop While rst.Fields(0) = PrefixeGroupe 'tant que c'est le même groupe d'entreprises
xlBook.SaveAs Lec_Param("Chemin") & " " & MyFile 'enregistrement du fichier chemin contenu dans le paramètre +nom ds la variable
xlApp.Quit 'on quitte excel
' MsgBox "Le fichier " & " " & MyFile & Chr(13) & "a été crée dans le répertoire : " & Chr(13) & Lec_Param("CHEMIN"), vbInformation, "Création réussie"
Call Affiche("Le fichier " & MyFile & " a été crée dans le répertoire : " & Lec_Param("CHEMIN"), 1)
Loop Until rst.EOF
'on libère les instances
Set rst = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End Function |
Programmer en VBA pour groupements
Répondre avec citation
Partager