Discussion :

[Salo15]

Parfait. Je vois que vous savez vous débrouiller!
Bonne continuation.

Merci, je vous ai écrit une dernière question juste au dessus, j'espère que ça ne vous dérangera pas d'y jeter un coup d'œil.

Merci par avance

[tee_grandbois]

bonsoir,
il manque l'évaluation de l'expression :

Code :

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

If InStr(1, Range("A" & x).Value, "cf.") <> 0

[EricDgn]

Effectivement, il manque le > 0.
Et pour effectuer cela immédiatement, vous pouvez insérer ce code juste entre le Loop et le End With:

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
'       Loop
        '--- mise en italique
        .Range("A1:A200").Font.Italic = True
        For i = 1 To 200
            Set Rng = .Range("A" & i)
            If InStr(1, Rng.Value, "cf.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "cf."), Len("cf.")).Font.Italic = False
            If InStr(1, Rng.Value, "s.l.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "s.l."), Len("s.l.")).Font.Italic = False
            If InStr(1, Rng.Value, "fo.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "fo."), Len("fo.")).Font.Italic = False
            If InStr(1, Rng.Value, "ssp.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "ssp."), Len("ssp.")).Font.Italic = False
            If InStr(1, Rng.Value, "agg.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "agg."), Len("agg.")).Font.Italic = False
            If InStr(1, Rng.Value, "sp.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "sp."), Len("sp.")).Font.Italic = False
            If InStr(1, Rng.Value, "Indeterminata") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Indeterminata"), Len("Indeterminata")).Font.Italic = False
            If InStr(1, Rng.Value, "Rosaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Rosaceae"), Len("Rosaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Leguminosae sativae indeterminatae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Leguminosae sativae indeterminatae"), Len("Leguminosae sativae indeterminatae")).Font.Italic = False
            If InStr(1, Rng.Value, "Amaranthaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Amaranthaceae"), Len("Amaranthaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Apiaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Apiaceae"), Len("Apiaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Cerealia indeterminata") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Cerealia indeterminata"), Len("Cerealia indeterminata")).Font.Italic = False
            If InStr(1, Rng.Value, "Asteraceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Asteraceae"), Len("Asteraceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Caryophyllaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Caryophyllaceae"), Len("Caryophyllaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Coleoptera") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Coleoptera"), Len("Coleoptera")).Font.Italic = False
            If InStr(1, Rng.Value, "Coprolithe") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Coprolithe"), Len("Coprolithe")).Font.Italic = False
            If InStr(1, Rng.Value, "Fabaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Fabaceae"), Len("Fabaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Gasteropoda") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Gasteropoda"), Len("Gasteropoda")).Font.Italic = False
            If InStr(1, Rng.Value, "Lamiaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Lamiaceae"), Len("Lamiaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Liliaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Liliaceae"), Len("Liliaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Pain/galette/bouillie") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Pain/galette/bouillie"), Len("Pain/galette/bouillie")).Font.Italic = False
            If InStr(1, Rng.Value, "Panicoideae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Panicoideae"), Len("Panicoideae")).Font.Italic = False
            If InStr(1, Rng.Value, "Poaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Poaceae"), Len("Poaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Polygonaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Polygonaceae"), Len("Polygonaceae")).Font.Italic = False
        Next i
'   End With

A tester.
Cordialement.

[Salo15]

bonsoir,
il manque l'évaluation de l'expression :

Code :

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

If InStr(1, Range("A" & x).Value, "cf.") <> 0

Bonsoir,

Merci beaucoup pour votre remarque, du coup j'ai essayé avec If InStr(1, Range("A" & x).Value, "cf.") > 0 et ça marche !

[Salo15]

Effectivement, il manque le > 0.
Et pour effectuer cela immédiatement, vous pouvez insérer ce code juste entre le Loop et le End With:

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
'       Loop
        '--- mise en italique
        .Range("A1:A200").Font.Italic = True
        For i = 1 To 200
            Set Rng = .Range("A" & i)
            If InStr(1, Rng.Value, "cf.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "cf."), Len("cf.")).Font.Italic = False
            If InStr(1, Rng.Value, "s.l.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "s.l."), Len("s.l.")).Font.Italic = False
            If InStr(1, Rng.Value, "fo.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "fo."), Len("fo.")).Font.Italic = False
            If InStr(1, Rng.Value, "ssp.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "ssp."), Len("ssp.")).Font.Italic = False
            If InStr(1, Rng.Value, "agg.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "agg."), Len("agg.")).Font.Italic = False
            If InStr(1, Rng.Value, "sp.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "sp."), Len("sp.")).Font.Italic = False
            If InStr(1, Rng.Value, "Indeterminata") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Indeterminata"), Len("Indeterminata")).Font.Italic = False
            If InStr(1, Rng.Value, "Rosaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Rosaceae"), Len("Rosaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Leguminosae sativae indeterminatae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Leguminosae sativae indeterminatae"), Len("Leguminosae sativae indeterminatae")).Font.Italic = False
            If InStr(1, Rng.Value, "Amaranthaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Amaranthaceae"), Len("Amaranthaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Apiaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Apiaceae"), Len("Apiaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Cerealia indeterminata") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Cerealia indeterminata"), Len("Cerealia indeterminata")).Font.Italic = False
            If InStr(1, Rng.Value, "Asteraceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Asteraceae"), Len("Asteraceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Caryophyllaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Caryophyllaceae"), Len("Caryophyllaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Coleoptera") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Coleoptera"), Len("Coleoptera")).Font.Italic = False
            If InStr(1, Rng.Value, "Coprolithe") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Coprolithe"), Len("Coprolithe")).Font.Italic = False
            If InStr(1, Rng.Value, "Fabaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Fabaceae"), Len("Fabaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Gasteropoda") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Gasteropoda"), Len("Gasteropoda")).Font.Italic = False
            If InStr(1, Rng.Value, "Lamiaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Lamiaceae"), Len("Lamiaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Liliaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Liliaceae"), Len("Liliaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Pain/galette/bouillie") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Pain/galette/bouillie"), Len("Pain/galette/bouillie")).Font.Italic = False
            If InStr(1, Rng.Value, "Panicoideae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Panicoideae"), Len("Panicoideae")).Font.Italic = False
            If InStr(1, Rng.Value, "Poaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Poaceae"), Len("Poaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Polygonaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Polygonaceae"), Len("Polygonaceae")).Font.Italic = False
        Next i
'   End With

A tester.
Cordialement.

Bonsoir,

Une fois de plus, merci beaucoup pour votre aide et votre réactivité. Cela marche parfaitement ! J'ai réussi à avoir le tableur que dont j'avais besoin.
Merci et bonne continuation !

[Salo15]

Bonjour,

Je suis désolée de vous déranger encore une fois, cette fois-ci je souhaite que la plage de données collée avec transposition sois mise en gras.

Pour cela, à la partie du code collage spécial transposé qui marche très bien (lignes 2 et 3), j'ai rajouté la ligne 4 mais cela ne marche pas :

Code :

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

1
2
3
4
' transposer à l'endroit souhaité
 Rng.copy
 xlWs.Range("F1").pastespecial transpose:=True
 xlWs.Range("F1:F27", xlWs.Range("F1:F27").End(xlToRight)).Font.Bold = True

Merci par avance

[EricDgn]

Bonjour,

Essayez ceci:

Code :

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

1
2
3
4
' transpose à l'endroit souhaité
    Rng.Copy
    xlWs.Range("F1").PasteSpecial Paste:=-4163, Transpose:=True
    xlWs.UsedRange.Font.Bold = True

Mais il me semble qu'il y a en cela une certaine contradiction avec une de vos décisions précédentes où vous vouliez conserver les formats, cela en utilisant Cells.ClearContents plutôt que Cells.Delete. Pourquoi ne pas fixer les formats en gras pour l'entièreté des lignes du haut concernées.

Cordialement.

[Salo15]

Bonjour Eric,
En effet, vous avez raison. Je vous explique. Après avoir obtenu le code avec Cells.ClearContents qui marchait très bien, j'ai fait plusieurs tests et j'ai été confrontée à un problème que je n'avais pas su prévoir : étant donné que les sous-titres des catégories des taxons (à partir de la cellule B29 vers le bas) sont en gras, à chaque fois que j'exporte les données d'un site archéologique différent, les noms des taxons qui vont se trouver à la place des sous-titres de l'ancien tableau vont s'afficher en gras, or, les noms des taxons ne doivent pas s'afficher en gras. En effet, Cells.ClearContents marcherait très bien si je n'avais pas besoin que les sous-titres soient en gras, car cela me permettrait de garder la largeur des colonnes, mais du coup, je préfère revenir à Cells.Delete afin de résoudre le problème des taxons qui s'affichent mal, de demander à ce que les en-têtes soient en gras, et je m'occuperai manuellement d'adapter la largeur des colonnes.

Trouvez-vous que c'est un bon choix de ma part? j'ai fait plusieurs tests et cela a l'air de marcher. Sinon, l'autre solution serait de demander avec le code d'effacer les données du tableau (Cells.ClearContents) mais de supprimer les données (Cells.Delete) à partir de la cellule B29 vers le bas (je suis sûre que c'est toujours à partir de cette cellule qui s'afficheront les taxons). Mais je ne sais pas si c'est possible ni comment le faire.

Pour ce qui est de

Code :

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

xlWs.UsedRange.Font.Bold = True

Cela me met tout mon tableur en gras... il faudrait peut-être définir la plage ? l'en-tête s'affichera toujours à partir de la plage (F1:F27) et vers la droite, la fin de la plage varie d'un site à l'autre.
Encore un grand merci

[EricDgn]

Bonjour,

Pourriez-vous donner l'ensemble du code de la macro Exporter_RQT_Click() car je ne sais plus exactement en quoi elle consiste.

Cordialement.

[Salo15]

Bonjour,

Pourriez-vous donner l'ensemble du code de la macro Exporter_RQT_Click() car je ne sais plus exactement en quoi elle consiste.

Cordialement.

Re-bonjour,

Bien sûr, voici le code avec xlWs.Cells.ClearContents

Merci par avance

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
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
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
Option Explicit
 
Private Sub Exporter_RQT_Click()
 
Dim oRst As Recordset
Dim oDb As Database
Dim xlApp As Object
Dim xlWb As Object
Dim xlWs As Object
Dim i As Long
Dim Rng As Object
Dim xlWsTmp As Object
Dim sTitre As String
 
    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Open("C:\Users\Laura\Desktop\Thèse\BDD\BDRAB thèse\Tableurs_Decompte\Export.xlsx")
' rendre visible Excel
    xlApp.Visible = True
 
    Set oDb = CurrentDb()
 
'--- Export table1
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_PresentationEchant")
' définition feuille 1
    Set xlWs = xlWb.Worksheets("PresentationEchant")
 
' efface les anciennes données table 1
    xlWs.Select
    xlWs.Cells.ClearContents
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A1").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 1
    If Not oRst.EOF Then xlWs.Cells(2, 1).CopyFromRecordset oRst
    xlWs.Range("A1").Select
 
'--- Export table2
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_AC_EchantColonne_TaxonLigne")
 
' définition feuille 2
    Set xlWs = xlWb.Worksheets("Decompte")
 
' efface les anciennes données table 2
    xlWs.Select
    xlWs.Cells.ClearContents
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A28").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 2
    If Not oRst.EOF Then xlWs.Range("A29").CopyFromRecordset oRst
    xlWs.Range("A28").Select
 
'Pour chaque ligne de la feuille à partir de la ligne 29
    xlWs.Select
    sTitre = ""
    i = 29
    With xlWs
        Do While .Range("A" & i).Value <> ""
            If .Range("F" & i).Value <> sTitre Then
                sTitre = .Range("F" & i).Value
                .Range("A" & i).EntireRow.Insert shift:=-4121, CopyOrigin:=0
                .Range("B" & i).Value = sTitre
                .Range("B" & i).Font.Bold = True
            End If
            i = i + 1
        Loop
 
   '--- mise en italique
        .Range("B29:B200").Font.Italic = True
        For i = 29 To 200
            Set Rng = .Range("B" & i)
            If InStr(1, Rng.Value, "A. Céréales") > 0 Then Rng.Characters(InStr(1, Rng.Value, "A. Céréales"), Len("A. Céréales")).Font.Italic = False
            If InStr(1, Rng.Value, "B. Légumineuses") > 0 Then Rng.Characters(InStr(1, Rng.Value, "B. Légumineuses"), Len("B. Légumineuses")).Font.Italic = False
            If InStr(1, Rng.Value, "C. Légumes") > 0 Then Rng.Characters(InStr(1, Rng.Value, "C. Légumes"), Len("C. Légumes")).Font.Italic = False
            If InStr(1, Rng.Value, "D. Plantes aromatiques/oléagineuses/textiles") > 0 Then Rng.Characters(InStr(1, Rng.Value, "D. Plantes aromatiques/oléagineuses/textiles"), Len("D. Plantes aromatiques/oléagineuses/textiles")).Font.Italic = False
            If InStr(1, Rng.Value, "E. Plantes tinctoriales") > 0 Then Rng.Characters(InStr(1, Rng.Value, "E. Plantes tinctoriales"), Len("E. Plantes tinctoriales")).Font.Italic = False
            If InStr(1, Rng.Value, "F. Forêts, lisières, clairières, coupes, haies, fourrés") > 0 Then Rng.Characters(InStr(1, Rng.Value, "F. Forêts, lisières, clairières, coupes, haies, fourrés"), Len("F. Forêts, lisières, clairières, coupes, haies, fourrés")).Font.Italic = False
            If InStr(1, Rng.Value, "G. Messicoles") > 0 Then Rng.Characters(InStr(1, Rng.Value, "G. Messicoles"), Len("G. Messicoles")).Font.Italic = False
            If InStr(1, Rng.Value, "H. Végétation de zones ouvertes, pelouses et prairies") > 0 Then Rng.Characters(InStr(1, Rng.Value, "H. Végétation de zones ouvertes, pelouses et prairies"), Len("H. Végétation de zones ouvertes, pelouses et prairies")).Font.Italic = False
            If InStr(1, Rng.Value, "I. Adventices, végétation de zones rudérales et autre végétation synanthrope") > 0 Then Rng.Characters(InStr(1, Rng.Value, "I. Adventices, végétation de zones rudérales et autre végétation synanthrope"), Len("I. Adventices, végétation de zones rudérales et autre végétation synanthrope")).Font.Italic = False
            If InStr(1, Rng.Value, "J. Plantes de zones humides") > 0 Then Rng.Characters(InStr(1, Rng.Value, "J. Plantes de zones humides"), Len("J. Plantes de zones humides")).Font.Italic = False
            If InStr(1, Rng.Value, "K. Plantes aquatiques") > 0 Then Rng.Characters(InStr(1, Rng.Value, "K. Plantes aquatiques"), Len("K. Plantes aquatiques")).Font.Italic = False
            If InStr(1, Rng.Value, "L. Divers") > 0 Then Rng.Characters(InStr(1, Rng.Value, "L. Divers"), Len("L. Divers")).Font.Italic = False
            If InStr(1, Rng.Value, "M. Algues vertes") > 0 Then Rng.Characters(InStr(1, Rng.Value, "M. Algues vertes"), Len("M. Algues vertes")).Font.Italic = False
            If InStr(1, Rng.Value, "N. Fougères") > 0 Then Rng.Characters(InStr(1, Rng.Value, "N. Fougères"), Len("N. Fougères")).Font.Italic = False
            If InStr(1, Rng.Value, "O. Bryophytes (mousses)") > 0 Then Rng.Characters(InStr(1, Rng.Value, "O. Bryophytes (mousses)"), Len("O. Bryophytes (mousses)")).Font.Italic = False
            If InStr(1, Rng.Value, "P. Lichens") > 0 Then Rng.Characters(InStr(1, Rng.Value, "P. Lichens"), Len("P. Lichens")).Font.Italic = False
            If InStr(1, Rng.Value, "Q. Champignons") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Q. Champignons"), Len("Q. Champignons")).Font.Italic = False
            If InStr(1, Rng.Value, "R. Insectes") > 0 Then Rng.Characters(InStr(1, Rng.Value, "R. Insectes"), Len("R. Insectes")).Font.Italic = False
            If InStr(1, Rng.Value, "S. Mollusques") > 0 Then Rng.Characters(InStr(1, Rng.Value, "S. Mollusques"), Len("S. Mollusques")).Font.Italic = False
            If InStr(1, Rng.Value, "T. Crustacés") > 0 Then Rng.Characters(InStr(1, Rng.Value, "T. Crustacés"), Len("T. Crustacés")).Font.Italic = False
            If InStr(1, Rng.Value, "U. Matière organique (MO)") > 0 Then Rng.Characters(InStr(1, Rng.Value, "U. Matière organique (MO)"), Len("U. Matière organique (MO)")).Font.Italic = False
            If InStr(1, Rng.Value, "cf.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "cf."), Len("cf.")).Font.Italic = False
            If InStr(1, Rng.Value, "s.l.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "s.l."), Len("s.l.")).Font.Italic = False
            If InStr(1, Rng.Value, "fo.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "fo."), Len("fo.")).Font.Italic = False
            If InStr(1, Rng.Value, "ssp.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "ssp."), Len("ssp.")).Font.Italic = False
            If InStr(1, Rng.Value, "agg.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "agg."), Len("agg.")).Font.Italic = False
            If InStr(1, Rng.Value, "sp.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "sp."), Len("sp.")).Font.Italic = False
            If InStr(1, Rng.Value, "Indeterminata") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Indeterminata"), Len("Indeterminata")).Font.Italic = False
            If InStr(1, Rng.Value, "Rosaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Rosaceae"), Len("Rosaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Leguminosae sativae indeterminatae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Leguminosae sativae indeterminatae"), Len("Leguminosae sativae indeterminatae")).Font.Italic = False
            If InStr(1, Rng.Value, "Amaranthaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Amaranthaceae"), Len("Amaranthaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Apiaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Apiaceae"), Len("Apiaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Cerealia indeterminata") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Cerealia indeterminata"), Len("Cerealia indeterminata")).Font.Italic = False
            If InStr(1, Rng.Value, "Asteraceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Asteraceae"), Len("Asteraceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Caryophyllaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Caryophyllaceae"), Len("Caryophyllaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Coleoptera") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Coleoptera"), Len("Coleoptera")).Font.Italic = False
            If InStr(1, Rng.Value, "Coprolithe") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Coprolithe"), Len("Coprolithe")).Font.Italic = False
            If InStr(1, Rng.Value, "Fabaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Fabaceae"), Len("Fabaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Gasteropoda") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Gasteropoda"), Len("Gasteropoda")).Font.Italic = False
            If InStr(1, Rng.Value, "Lamiaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Lamiaceae"), Len("Lamiaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Liliaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Liliaceae"), Len("Liliaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Pain/galette/bouillie") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Pain/galette/bouillie"), Len("Pain/galette/bouillie")).Font.Italic = False
            If InStr(1, Rng.Value, "Panicoideae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Panicoideae"), Len("Panicoideae")).Font.Italic = False
            If InStr(1, Rng.Value, "Poaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Poaceae"), Len("Poaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Polygonaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Polygonaceae"), Len("Polygonaceae")).Font.Italic = False
 
        Next i
 
    End With
 
'--- Export table3
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_InfosEchant")
 
' définition feuille Tmp (reçoit données à transposer)
    Set xlWsTmp = xlWb.Worksheets("Tmp")   '<--- avoir aussi une feuille nommée Tmp
    xlWsTmp.Select
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWsTmp.Range("A1").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 3
    If Not oRst.EOF Then xlWsTmp.Range("A2").CopyFromRecordset oRst
    xlWsTmp.Range("A1").Select
 
' récupère données
    Set Rng = xlWsTmp.UsedRange
 
' transpose à l'endroit souhaité
    Rng.Copy
     xlWs.Range("F1").PasteSpecial Paste:=-4163, Transpose:=True
 
' vide plage temporaire
    Rng.Clear
    xlWs.Select
 
' fermeture des instances ouvertes
    oRst.Close
    xlWb.Close True
    Set oRst = Nothing
    Set oDb = Nothing
    Set Rng = Nothing
    Set xlWsTmp = Nothing
    Set xlWs = Nothing
    Set xlWb = Nothing
    Set xlApp = Nothing
 
End Sub

[EricDgn]

Voilà, c'est quasi près la même chose, mais avec les exports et insertions faits en ordre différent:
- d'abord la table1, ensuite la table3, enfin la table2
- pour la table2, d'abord mise en italique (non gras), ensuite ajout des sous-titres (en gras)
Cela devrait permettre de conserver les mises en page d'un export à l'autre. A tester.

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
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
132
133
134
135
136
137
138
139
140
141
142
143
Private Sub Exporter_RQT_Click()
 
Dim oRst As Recordset
Dim oDb As Database
Dim xlApp As Object
Dim xlWb As Object
Dim xlWs As Object
Dim i As Long
Dim Rng As Object
Dim xlwsTmp As Object
Dim sTitre As String
 
    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Open("C:\Users\Laura\Desktop\Thèse\BDD\BDRAB thèse\Tableurs_Decompte\Export.xlsx")
' rendre visible Excel
    xlApp.Visible = True
 
    Set oDb = CurrentDb()
 
'--- Export table1 dans feuille "PresentationEchant"
 
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_PresentationEchant")
    Set xlWs = xlWb.Worksheets("PresentationEchant")
 
' efface les anciennes données table 1
    xlWs.Select
    xlWs.Cells.ClearContents
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A1").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 1
    If Not oRst.EOF Then xlWs.Cells(2, 1).CopyFromRecordset oRst
    xlWs.Range("A1").Select
 
'--- Export table3 dans la feuille "Tmp" puis recopie transposée dans feuille "Decompte"
 
    Set xlWs = xlWb.Worksheets("Decompte")
 
' efface les anciennes données table 2
    xlWs.Select
    xlWs.Cells.ClearContents
 
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_InfosEchant")
 
' définition feuille Tmp (reçoit données à transposer)
    Set xlwsTmp = xlWb.Worksheets("Tmp")   '<--- avoir aussi une feuille nommée Tmp
    xlwsTmp.Select
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlwsTmp.Range("A1").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 3
    If Not oRst.EOF Then xlwsTmp.Range("A2").CopyFromRecordset oRst
    xlwsTmp.Range("A1").Select
 
' récupère données
    Set Rng = xlwsTmp.UsedRange
 
' transpose à l'endroit souhaité
    Rng.Copy
    xlWs.Range("F1").PasteSpecial Paste:=-4163, Transpose:=True
 
' vide plage temporaire
    Rng.Clear
    xlWs.Select
 
'--- Export table2 dans feuille "Decompte"
 
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_AC_EchantColonne_TaxonLigne")
 
' entête dans 1ère ligne en A28
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A28").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 2
    If Not oRst.EOF Then xlWs.Range("A29").CopyFromRecordset oRst
    xlWs.Range("A28").Select
 
' Pour chaque ligne de la feuille à partir de la ligne 29
    xlWs.Select
    With xlWs
        '--- mise en italique
        i = 29
        Do While .Range("B" & i).Value <> ""            '--- parcourt la liste jusqu'à tomber sur celule vide
            Set Rng = .Range("B" & i)
            Rng.Font.Bold = False
            Rng.Font.Italic = True
            If InStr(1, Rng.Value, "cf.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "cf."), Len("cf.")).Font.Italic = False
            If InStr(1, Rng.Value, "s.l.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "s.l."), Len("s.l.")).Font.Italic = False
            If InStr(1, Rng.Value, "fo.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "fo."), Len("fo.")).Font.Italic = False
            If InStr(1, Rng.Value, "ssp.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "ssp."), Len("ssp.")).Font.Italic = False
            If InStr(1, Rng.Value, "agg.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "agg."), Len("agg.")).Font.Italic = False
            If InStr(1, Rng.Value, "sp.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "sp."), Len("sp.")).Font.Italic = False
            If InStr(1, Rng.Value, "Indeterminata") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Indeterminata"), Len("Indeterminata")).Font.Italic = False
            If InStr(1, Rng.Value, "Rosaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Rosaceae"), Len("Rosaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Leguminosae sativae indeterminatae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Leguminosae sativae indeterminatae"), Len("Leguminosae sativae indeterminatae")).Font.Italic = False
            If InStr(1, Rng.Value, "Amaranthaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Amaranthaceae"), Len("Amaranthaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Apiaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Apiaceae"), Len("Apiaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Cerealia indeterminata") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Cerealia indeterminata"), Len("Cerealia indeterminata")).Font.Italic = False
            If InStr(1, Rng.Value, "Asteraceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Asteraceae"), Len("Asteraceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Caryophyllaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Caryophyllaceae"), Len("Caryophyllaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Coleoptera") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Coleoptera"), Len("Coleoptera")).Font.Italic = False
            If InStr(1, Rng.Value, "Coprolithe") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Coprolithe"), Len("Coprolithe")).Font.Italic = False
            If InStr(1, Rng.Value, "Fabaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Fabaceae"), Len("Fabaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Gasteropoda") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Gasteropoda"), Len("Gasteropoda")).Font.Italic = False
            If InStr(1, Rng.Value, "Lamiaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Lamiaceae"), Len("Lamiaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Liliaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Liliaceae"), Len("Liliaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Pain/galette/bouillie") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Pain/galette/bouillie"), Len("Pain/galette/bouillie")).Font.Italic = False
            If InStr(1, Rng.Value, "Panicoideae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Panicoideae"), Len("Panicoideae")).Font.Italic = False
            If InStr(1, Rng.Value, "Poaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Poaceae"), Len("Poaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Polygonaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Polygonaceae"), Len("Polygonaceae")).Font.Italic = False
        Loop
        '--- ajouts des sous-titres
        sTitre = ""
        i = 29
        Do While .Range("A" & i).Value <> ""            '--- parcourt la liste jusqu'à tomber sur celule vide
            If .Range("F" & i).Value <> sTitre Then
                sTitre = .Range("F" & i).Value
                .Range("A" & i).EntireRow.Insert shift:=-4121, CopyOrigin:=1    '<-- 1 sans doute préférable à 0
                .Range("B" & i).Value = sTitre
                .Range("B" & i).Font.Bold = True
            End If
            i = i + 1
        Loop
    End With
 
' fermeture des instances ouvertes
    oRst.Close
    xlWb.Close True
    Set oRst = Nothing
    Set oDb = Nothing
    Set Rng = Nothing
    Set xlwsTmp = Nothing
    Set xlWs = Nothing
    Set xlWb = Nothing
    Set xlApp = Nothing
End Sub

Cordialement.

[Salo15]

Voilà, c'est quasi près la même chose, mais avec les exports et insertions faits en ordre différent:
- d'abord la table1, ensuite la table3, enfin la table2
- pour la table2, d'abord mise en italique (non gras), ensuite ajout des sous-titres (en gras)
Cela devrait permettre de conserver les mises en page d'un export à l'autre. A tester.
Cordialement.

J'ai fait plusieurs tests mais malheureusement ça ne marche pas, à l'ouverture du fichier, Excel se bloque et n'exécute pas tout ce qu'on lui demande, on dirait qu'il ne termine pas la tâche d'enlever l'italique de certains caractères du nom des taxons (par exemple "cf.") et il n'ajoute pas les sous-titres non plus. De plus, la plage C29:C31 et toutes les colonnes qui suivent vers la droite se mettent en gras et ne je sais pas d'où ça vient, alors que dans la feuille ancienne cette plage n'est pas en gras (voir l'image)

Sinon, j'ai essayé avec ce code qui n'est pas "propre". Cela marche mais du coup j'ai toujours le problème de la plage qui se met en gras sans raison apparente, cette fois-ci c'est la plage C30:C32 et toutes les colonnes qui suivent vers la droite.

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
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
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
Private Sub Exporter_RQT_Click()
 
Dim oRst As Recordset
Dim oDb As Database
Dim xlApp As Object
Dim xlWb As Object
Dim xlWs As Object
Dim i As Long
Dim Rng As Object
Dim xlWsTmp As Object
Dim sTitre As String
 
    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Open("C:\Users\Laura\Desktop\Thèse\BDD\BDRAB thèse\Tableurs_Decompte\Export.xlsx")
' rendre visible Excel
    xlApp.Visible = True
 
    Set oDb = CurrentDb()
 
'--- Export table1
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_PresentationEchant")
' définition feuille 1
    Set xlWs = xlWb.Worksheets("PresentationEchant")
 
' efface les anciennes données table 1
    xlWs.Select
    xlWs.Cells.ClearContents
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A1").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 1
    If Not oRst.EOF Then xlWs.Cells(2, 1).CopyFromRecordset oRst
    xlWs.Range("A1").Select
 
'--- Export table2
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_AC_EchantColonne_TaxonLigne")
 
' définition feuille 2
    Set xlWs = xlWb.Worksheets("Decompte")
 
' efface les anciennes données table 2
    xlWs.Select
    xlWs.Cells.ClearContents
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A28").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 2
    If Not oRst.EOF Then xlWs.Range("A29").CopyFromRecordset oRst
    xlWs.Range("A28").Select
 
'Pour chaque ligne de la feuille à partir de la ligne 29
 
   '--- mise en italique
        xlWs.Range("B29:B200").Font.Italic = True
        xlWs.Range("B29:B200").Font.Bold = False
        For i = 29 To 200
            Set Rng = xlWs.Range("B" & i)
            If InStr(1, Rng.Value, "A. Céréales") > 0 Then Rng.Characters(InStr(1, Rng.Value, "A. Céréales"), Len("A. Céréales")).Font.Italic = False
            If InStr(1, Rng.Value, "B. Légumineuses") > 0 Then Rng.Characters(InStr(1, Rng.Value, "B. Légumineuses"), Len("B. Légumineuses")).Font.Italic = False
            If InStr(1, Rng.Value, "C. Légumes") > 0 Then Rng.Characters(InStr(1, Rng.Value, "C. Légumes"), Len("C. Légumes")).Font.Italic = False
            If InStr(1, Rng.Value, "D. Plantes aromatiques/oléagineuses/textiles") > 0 Then Rng.Characters(InStr(1, Rng.Value, "D. Plantes aromatiques/oléagineuses/textiles"), Len("D. Plantes aromatiques/oléagineuses/textiles")).Font.Italic = False
            If InStr(1, Rng.Value, "E. Plantes tinctoriales") > 0 Then Rng.Characters(InStr(1, Rng.Value, "E. Plantes tinctoriales"), Len("E. Plantes tinctoriales")).Font.Italic = False
            If InStr(1, Rng.Value, "F. Forêts, lisières, clairières, coupes, haies, fourrés") > 0 Then Rng.Characters(InStr(1, Rng.Value, "F. Forêts, lisières, clairières, coupes, haies, fourrés"), Len("F. Forêts, lisières, clairières, coupes, haies, fourrés")).Font.Italic = False
            If InStr(1, Rng.Value, "G. Messicoles") > 0 Then Rng.Characters(InStr(1, Rng.Value, "G. Messicoles"), Len("G. Messicoles")).Font.Italic = False
            If InStr(1, Rng.Value, "H. Végétation de zones ouvertes, pelouses et prairies") > 0 Then Rng.Characters(InStr(1, Rng.Value, "H. Végétation de zones ouvertes, pelouses et prairies"), Len("H. Végétation de zones ouvertes, pelouses et prairies")).Font.Italic = False
            If InStr(1, Rng.Value, "I. Adventices, végétation de zones rudérales et autre végétation synanthrope") > 0 Then Rng.Characters(InStr(1, Rng.Value, "I. Adventices, végétation de zones rudérales et autre végétation synanthrope"), Len("I. Adventices, végétation de zones rudérales et autre végétation synanthrope")).Font.Italic = False
            If InStr(1, Rng.Value, "J. Plantes de zones humides") > 0 Then Rng.Characters(InStr(1, Rng.Value, "J. Plantes de zones humides"), Len("J. Plantes de zones humides")).Font.Italic = False
            If InStr(1, Rng.Value, "K. Plantes aquatiques") > 0 Then Rng.Characters(InStr(1, Rng.Value, "K. Plantes aquatiques"), Len("K. Plantes aquatiques")).Font.Italic = False
            If InStr(1, Rng.Value, "L. Divers") > 0 Then Rng.Characters(InStr(1, Rng.Value, "L. Divers"), Len("L. Divers")).Font.Italic = False
            If InStr(1, Rng.Value, "M. Algues vertes") > 0 Then Rng.Characters(InStr(1, Rng.Value, "M. Algues vertes"), Len("M. Algues vertes")).Font.Italic = False
            If InStr(1, Rng.Value, "N. Fougères") > 0 Then Rng.Characters(InStr(1, Rng.Value, "N. Fougères"), Len("N. Fougères")).Font.Italic = False
            If InStr(1, Rng.Value, "O. Bryophytes (mousses)") > 0 Then Rng.Characters(InStr(1, Rng.Value, "O. Bryophytes (mousses)"), Len("O. Bryophytes (mousses)")).Font.Italic = False
            If InStr(1, Rng.Value, "P. Lichens") > 0 Then Rng.Characters(InStr(1, Rng.Value, "P. Lichens"), Len("P. Lichens")).Font.Italic = False
            If InStr(1, Rng.Value, "Q. Champignons") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Q. Champignons"), Len("Q. Champignons")).Font.Italic = False
            If InStr(1, Rng.Value, "R. Insectes") > 0 Then Rng.Characters(InStr(1, Rng.Value, "R. Insectes"), Len("R. Insectes")).Font.Italic = False
            If InStr(1, Rng.Value, "S. Mollusques") > 0 Then Rng.Characters(InStr(1, Rng.Value, "S. Mollusques"), Len("S. Mollusques")).Font.Italic = False
            If InStr(1, Rng.Value, "T. Crustacés") > 0 Then Rng.Characters(InStr(1, Rng.Value, "T. Crustacés"), Len("T. Crustacés")).Font.Italic = False
            If InStr(1, Rng.Value, "U. Matière organique (MO)") > 0 Then Rng.Characters(InStr(1, Rng.Value, "U. Matière organique (MO)"), Len("U. Matière organique (MO)")).Font.Italic = False
            If InStr(1, Rng.Value, "cf.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "cf."), Len("cf.")).Font.Italic = False
            If InStr(1, Rng.Value, "s.l.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "s.l."), Len("s.l.")).Font.Italic = False
            If InStr(1, Rng.Value, "fo.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "fo."), Len("fo.")).Font.Italic = False
            If InStr(1, Rng.Value, "ssp.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "ssp."), Len("ssp.")).Font.Italic = False
            If InStr(1, Rng.Value, "agg.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "agg."), Len("agg.")).Font.Italic = False
            If InStr(1, Rng.Value, "sp.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "sp."), Len("sp.")).Font.Italic = False
            If InStr(1, Rng.Value, "Indeterminata") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Indeterminata"), Len("Indeterminata")).Font.Italic = False
            If InStr(1, Rng.Value, "Rosaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Rosaceae"), Len("Rosaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Leguminosae sativae indeterminatae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Leguminosae sativae indeterminatae"), Len("Leguminosae sativae indeterminatae")).Font.Italic = False
            If InStr(1, Rng.Value, "Amaranthaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Amaranthaceae"), Len("Amaranthaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Apiaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Apiaceae"), Len("Apiaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Cerealia indeterminata") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Cerealia indeterminata"), Len("Cerealia indeterminata")).Font.Italic = False
            If InStr(1, Rng.Value, "Asteraceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Asteraceae"), Len("Asteraceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Caryophyllaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Caryophyllaceae"), Len("Caryophyllaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Coleoptera") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Coleoptera"), Len("Coleoptera")).Font.Italic = False
            If InStr(1, Rng.Value, "Coprolithe") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Coprolithe"), Len("Coprolithe")).Font.Italic = False
            If InStr(1, Rng.Value, "Fabaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Fabaceae"), Len("Fabaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Gasteropoda") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Gasteropoda"), Len("Gasteropoda")).Font.Italic = False
            If InStr(1, Rng.Value, "Lamiaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Lamiaceae"), Len("Lamiaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Liliaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Liliaceae"), Len("Liliaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Pain/galette/bouillie") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Pain/galette/bouillie"), Len("Pain/galette/bouillie")).Font.Italic = False
            If InStr(1, Rng.Value, "Panicoideae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Panicoideae"), Len("Panicoideae")).Font.Italic = False
            If InStr(1, Rng.Value, "Poaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Poaceae"), Len("Poaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Polygonaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Polygonaceae"), Len("Polygonaceae")).Font.Italic = False
 
       Next i
 
'ajout de sous-titres
    xlWs.Select
    sTitre = ""
    i = 29
    With xlWs
        Do While .Range("A" & i).Value <> ""
            If .Range("F" & i).Value <> sTitre Then
                sTitre = .Range("F" & i).Value
                .Range("A" & i).EntireRow.Insert shift:=-4121, CopyOrigin:=0
                .Range("B" & i).Value = sTitre
                .Range("B" & i).Font.Bold = True
                .Range("B" & i).Font.Italic = False
            End If
            i = i + 1
        Loop
 
 
    End With
 
'--- Export table3
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_InfosEchant")
 
' définition feuille Tmp (reçoit données à transposer)
    Set xlWsTmp = xlWb.Worksheets("Tmp")   '<--- avoir aussi une feuille nommée Tmp
    xlWsTmp.Select
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWsTmp.Range("A1").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 3
    If Not oRst.EOF Then xlWsTmp.Range("A2").CopyFromRecordset oRst
    xlWsTmp.Range("A1").Select
 
' récupère données
    Set Rng = xlWsTmp.UsedRange
 
' transpose à l'endroit souhaité
    Rng.Copy
     xlWs.Range("F1").PasteSpecial Paste:=-4163, Transpose:=True
 
' vide plage temporaire
    Rng.Clear
    xlWs.Select
 
' fermeture des instances ouvertes
    oRst.Close
    xlWb.Close True
    Set oRst = Nothing
    Set oDb = Nothing
    Set Rng = Nothing
    Set xlWsTmp = Nothing
    Set xlWs = Nothing
    Set xlWb = Nothing
    Set xlApp = Nothing
 
End Sub

Bref, si ça devient trop compliqué, je peux rester sur le code que supprime les cellules au lieu d'en supprimer le contenu, dans ce cas là je voudrais mettre les en-têtes en gras.

Qu'en pensez-vous ?

Merci par avance

[EricDgn]

Qu'est-ce que cela donne quand on s'arrête à l'export de table1 et table3 ?

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
Private Sub Exporter_RQT_Click()
 
Dim oRst As Recordset
Dim oDb As Database
Dim xlApp As Object
Dim xlWb As Object
Dim xlWs As Object
Dim i As Long
Dim Rng As Object
Dim xlWsTmp As Object
Dim sTitre As String
 
    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Open("C:\Users\Laura\Desktop\Thèse\BDD\BDRAB thèse\Tableurs_Decompte\Export.xlsx")
' rendre visible Excel
    xlApp.Visible = True
 
    Set oDb = CurrentDb()
 
'--- Export table1 dans feuille "PresentationEchant"
 
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_PresentationEchant")
    Set xlWs = xlWb.Worksheets("PresentationEchant")
 
' efface les anciennes données table 1
    xlWs.Select
    xlWs.Cells.ClearContents
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A1").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 1
    If Not oRst.EOF Then xlWs.Cells(2, 1).CopyFromRecordset oRst
    xlWs.Range("A1").Select
 
'--- Export table3 dans la feuille "Tmp" puis recopie transposée dans feuille "Decompte"
 
    Set xlWs = xlWb.Worksheets("Decompte")
 
' efface les anciennes données table 2
    xlWs.Select
    xlWs.Cells.ClearContents
 
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_InfosEchant")
 
' définition feuille Tmp (reçoit données à transposer)
    Set xlWsTmp = xlWb.Worksheets("Tmp")   '<--- avoir aussi une feuille nommée Tmp
    xlWsTmp.Select
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWsTmp.Range("A1").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 3
    If Not oRst.EOF Then xlWsTmp.Range("A2").CopyFromRecordset oRst
    xlWsTmp.Range("A1").Select
 
' récupère données
    Set Rng = xlWsTmp.UsedRange
 
' transpose à l'endroit souhaité
    Rng.Copy
    xlWs.Range("F1").PasteSpecial Paste:=-4163, Transpose:=True
 
' vide plage temporaire
    Rng.Clear
    xlWs.Select
 
    Set oRst = Nothing
    Set oDb = Nothing
    Set Rng = Nothing
    Set xlWsTmp = Nothing
    Set xlWs = Nothing
    Set xlWb = Nothing
    Set xlApp = Nothing
End Sub

Cordialement.
P.S. Il est aussi possible d'ajouter en ligne 45: xlWs.Cells.ClearFormats

[Salo15]

Qu'est-ce que cela donne quand on s'arrête à l'export de table1 et table3 ?
Cordialement.
P.S. Il est aussi possible d'ajouter en ligne 45: xlWs.Cells.ClearFormats

Jusque là ça marche très bien, j'ai rajouté xlWs.Cells.ClearFormats et cela enlève la fonction gras de l'ancien tableau. C'est donc très bien. Par la suite, il faudrait que je dise dans mon code que la plage "A1:A28" et toutes les cellules vers la droite doivent se mettre en gras (ce sont les en-têtes de mon tableau).

[EricDgn]

A tester (ajout ligne 67 ou 68):

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
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
132
133
134
135
136
137
138
139
140
141
142
143
144
145
Private Sub Exporter_RQT_Click()
 
Dim oRst As Recordset
Dim oDb As Database
Dim xlApp As Object
Dim xlWb As Object
Dim xlWs As Object
Dim i As Long
Dim Rng As Object
Dim xlWsTmp As Object
Dim sTitre As String
 
    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Open("C:\Users\Laura\Desktop\Thèse\BDD\BDRAB thèse\Tableurs_Decompte\Export.xlsx")
' rendre visible Excel
    xlApp.Visible = True
 
    Set oDb = CurrentDb()
 
'--- Export table1 dans feuille "PresentationEchant"
 
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_PresentationEchant")
    Set xlWs = xlWb.Worksheets("PresentationEchant")
 
' efface les anciennes données table 1
    xlWs.Select
    xlWs.Cells.ClearContents
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A1").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 1
    If Not oRst.EOF Then xlWs.Cells(2, 1).CopyFromRecordset oRst
    xlWs.Range("A1").Select
 
'--- Export table3 dans la feuille "Tmp" puis recopie transposée dans feuille "Decompte"
 
    Set xlWs = xlWb.Worksheets("Decompte")
 
' efface les anciennes données table 2
    xlWs.Select
    xlWs.Cells.ClearContents
 
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_InfosEchant")
 
' définition feuille Tmp (reçoit données à transposer)
    Set xlWsTmp = xlWb.Worksheets("Tmp")   '<--- avoir aussi une feuille nommée Tmp
    xlWsTmp.Select
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWsTmp.Range("A1").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 3
    If Not oRst.EOF Then xlWsTmp.Range("A2").CopyFromRecordset oRst
    xlWsTmp.Range("A1").Select
 
' récupère données
    Set Rng = xlWsTmp.UsedRange
 
' transpose à l'endroit souhaité
    Rng.Copy
    xlWs.Range("F1").PasteSpecial Paste:=-4163, Transpose:=True
    xlWs.UsedRange.Font.Bold = True             '--- ceci
    'xlWs.Rows("1:28").Font.Bold = True          '--- ou ceci
 
' vide plage temporaire
    Rng.Clear
    xlWs.Select
 
'--- Export table2 dans feuille "Decompte"
 
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_AC_EchantColonne_TaxonLigne")
 
' entête dans 1ère ligne en A28
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A28").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 2
    If Not oRst.EOF Then xlWs.Range("A29").CopyFromRecordset oRst
    xlWs.Range("A28").Select
 
' Pour chaque ligne de la feuille à partir de la ligne 29
    xlWs.Select
    With xlWs
        '--- mise en italique
        i = 29
        Do While .Range("B" & i).Value <> ""            '--- parcourt la liste jusqu'à tomber sur celule vide
            Set Rng = .Range("B" & i)
            Rng.Font.Bold = False
            Rng.Font.Italic = True
            If InStr(1, Rng.Value, "cf.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "cf."), Len("cf.")).Font.Italic = False
            If InStr(1, Rng.Value, "s.l.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "s.l."), Len("s.l.")).Font.Italic = False
            If InStr(1, Rng.Value, "fo.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "fo."), Len("fo.")).Font.Italic = False
            If InStr(1, Rng.Value, "ssp.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "ssp."), Len("ssp.")).Font.Italic = False
            If InStr(1, Rng.Value, "agg.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "agg."), Len("agg.")).Font.Italic = False
            If InStr(1, Rng.Value, "sp.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "sp."), Len("sp.")).Font.Italic = False
            If InStr(1, Rng.Value, "Indeterminata") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Indeterminata"), Len("Indeterminata")).Font.Italic = False
            If InStr(1, Rng.Value, "Rosaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Rosaceae"), Len("Rosaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Leguminosae sativae indeterminatae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Leguminosae sativae indeterminatae"), Len("Leguminosae sativae indeterminatae")).Font.Italic = False
            If InStr(1, Rng.Value, "Amaranthaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Amaranthaceae"), Len("Amaranthaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Apiaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Apiaceae"), Len("Apiaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Cerealia indeterminata") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Cerealia indeterminata"), Len("Cerealia indeterminata")).Font.Italic = False
            If InStr(1, Rng.Value, "Asteraceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Asteraceae"), Len("Asteraceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Caryophyllaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Caryophyllaceae"), Len("Caryophyllaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Coleoptera") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Coleoptera"), Len("Coleoptera")).Font.Italic = False
            If InStr(1, Rng.Value, "Coprolithe") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Coprolithe"), Len("Coprolithe")).Font.Italic = False
            If InStr(1, Rng.Value, "Fabaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Fabaceae"), Len("Fabaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Gasteropoda") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Gasteropoda"), Len("Gasteropoda")).Font.Italic = False
            If InStr(1, Rng.Value, "Lamiaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Lamiaceae"), Len("Lamiaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Liliaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Liliaceae"), Len("Liliaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Pain/galette/bouillie") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Pain/galette/bouillie"), Len("Pain/galette/bouillie")).Font.Italic = False
            If InStr(1, Rng.Value, "Panicoideae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Panicoideae"), Len("Panicoideae")).Font.Italic = False
            If InStr(1, Rng.Value, "Poaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Poaceae"), Len("Poaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Polygonaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Polygonaceae"), Len("Polygonaceae")).Font.Italic = False
        Loop
        '--- ajouts des sous-titres
        sTitre = ""
        i = 29
        Do While .Range("A" & i).Value <> ""            '--- parcourt la liste jusqu'à tomber sur celule vide
            If .Range("F" & i).Value <> sTitre Then
                sTitre = .Range("F" & i).Value
                .Range("A" & i).EntireRow.Insert shift:=-4121, CopyOrigin:=1    '<-- 1 sans doute préférable à 0
                .Range("B" & i).Value = sTitre
                .Range("B" & i).Font.Bold = True
            End If
            i = i + 1
        Loop
    End With
 
' fermeture des instances ouvertes
    oRst.Close
    xlWb.Close True
    Set oRst = Nothing
    Set oDb = Nothing
    Set Rng = Nothing
    Set xlWsTmp = Nothing
    Set xlWs = Nothing
    Set xlWb = Nothing
    Set xlApp = Nothing
End Sub

Cordialement.

[Salo15]

A tester (ajout ligne 67 ou 68):
Cordialement.

Bonsoir,

Alors, voici ce que ça donne (image). Pour le problème de police en gras c'est réglé. Par contre, il doit y avoir quelque chose dans la partie du code "mise en italique" qu'il n'aime pas, car il le fait pour la cellule B29 mais près ça bloque et la partie "ajouts sous-titres" ne s'exécute pas non plus...
Il me met "erreur d'exécution '424' : Objet requis" et quand j'ouvre "débogage" à chaque fois il me signale une ligne différente de la partie du code "mise en italique", je n'arrive donc pas à comprendre d'où vient le problème...

[EricDgn]

Ah zut, j'ai fait un oubli classique: il faut ajouter l'instruction i = i + 1 juste avant le Loop à la ligne 120 !
Cordialement.

[Salo15]

Ah zut, j'ai fait un oubli classique: il faut ajouter l'instruction i = i + 1 juste avant le Loop à la ligne 120 !
Cordialement.

Bonjour Eric,
Encore un grand merci pour votre aide. Cela marche parfaitement. J'ai dû juste rajouter .Range("B" & i).Font.Italic = False à la ligne 130 pour enlever l'italique des sous-titres. Voici le code final :

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
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
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
Private Sub Exporter_RQT_Click()
 
Dim oRst As Recordset
Dim oDb As Database
Dim xlApp As Object
Dim xlWb As Object
Dim xlWs As Object
Dim i As Long
Dim Rng As Object
Dim xlWsTmp As Object
Dim sTitre As String
 
    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Open("C:\Users\Laura\Desktop\Thèse\BDD\BDRAB thèse\Tableurs_Decompte\Export.xlsx")
' rendre visible Excel
    xlApp.Visible = True
 
    Set oDb = CurrentDb()
 
'--- Export table1 dans feuille "PresentationEchant"
 
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_PresentationEchant")
    Set xlWs = xlWb.Worksheets("PresentationEchant")
 
' efface les anciennes données table 1
    xlWs.Select
    xlWs.Cells.ClearContents
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A1").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 1
    If Not oRst.EOF Then xlWs.Cells(2, 1).CopyFromRecordset oRst
    xlWs.Range("A1").Select
 
'--- Export table3 dans la feuille "Tmp" puis recopie transposée dans feuille "Decompte"
 
    Set xlWs = xlWb.Worksheets("Decompte")
 
' efface les anciennes données table 2
    xlWs.Select
    xlWs.Cells.ClearContents
 
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_InfosEchant")
 
' définition feuille Tmp (reçoit données à transposer)
    Set xlWsTmp = xlWb.Worksheets("Tmp")   '<--- avoir aussi une feuille nommée Tmp
    xlWsTmp.Select
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWsTmp.Range("A1").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 3
    If Not oRst.EOF Then xlWsTmp.Range("A2").CopyFromRecordset oRst
    xlWsTmp.Range("A1").Select
 
' récupère données
    Set Rng = xlWsTmp.UsedRange
 
' transpose à l'endroit souhaité
    Rng.Copy
    xlWs.Range("F1").PasteSpecial Paste:=-4163, Transpose:=True
    xlWs.Rows("1:30").Font.Bold = True
 
' vide plage temporaire
    Rng.Clear
    xlWs.Select
 
'--- Export table2 dans feuille "Decompte"
 
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_AC_EchantColonne_TaxonLigne")
 
' entête dans 1ère ligne en A30
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A30").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 2
    If Not oRst.EOF Then xlWs.Range("A31").CopyFromRecordset oRst
    xlWs.Range("A30").Select
 
' Pour chaque ligne de la feuille à partir de la ligne 31
    xlWs.Select
    With xlWs
        '--- mise en italique
        i = 31
        Do While .Range("B" & i).Value <> ""            '--- parcourt la liste jusqu'à tomber sur celule vide
            Set Rng = .Range("B" & i)
            Rng.Font.Bold = False
            Rng.Font.Italic = True
            If InStr(1, Rng.Value, "cf.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "cf."), Len("cf.")).Font.Italic = False
            If InStr(1, Rng.Value, "s.l.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "s.l."), Len("s.l.")).Font.Italic = False
            If InStr(1, Rng.Value, "fo.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "fo."), Len("fo.")).Font.Italic = False
            If InStr(1, Rng.Value, "ssp.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "ssp."), Len("ssp.")).Font.Italic = False
            If InStr(1, Rng.Value, "agg.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "agg."), Len("agg.")).Font.Italic = False
            If InStr(1, Rng.Value, "sp.") > 0 Then Rng.Characters(InStr(1, Rng.Value, "sp."), Len("sp.")).Font.Italic = False
            If InStr(1, Rng.Value, "Indeterminata") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Indeterminata"), Len("Indeterminata")).Font.Italic = False
            If InStr(1, Rng.Value, "Rosaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Rosaceae"), Len("Rosaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Leguminosae sativae indeterminatae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Leguminosae sativae indeterminatae"), Len("Leguminosae sativae indeterminatae")).Font.Italic = False
            If InStr(1, Rng.Value, "Amaranthaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Amaranthaceae"), Len("Amaranthaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Apiaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Apiaceae"), Len("Apiaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Cerealia indeterminata") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Cerealia indeterminata"), Len("Cerealia indeterminata")).Font.Italic = False
            If InStr(1, Rng.Value, "Asteraceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Asteraceae"), Len("Asteraceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Caryophyllaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Caryophyllaceae"), Len("Caryophyllaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Coleoptera") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Coleoptera"), Len("Coleoptera")).Font.Italic = False
            If InStr(1, Rng.Value, "Coprolithe") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Coprolithe"), Len("Coprolithe")).Font.Italic = False
            If InStr(1, Rng.Value, "Fabaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Fabaceae"), Len("Fabaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Gasteropoda") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Gasteropoda"), Len("Gasteropoda")).Font.Italic = False
            If InStr(1, Rng.Value, "Lamiaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Lamiaceae"), Len("Lamiaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Liliaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Liliaceae"), Len("Liliaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Pain/galette/bouillie") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Pain/galette/bouillie"), Len("Pain/galette/bouillie")).Font.Italic = False
            If InStr(1, Rng.Value, "Panicoideae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Panicoideae"), Len("Panicoideae")).Font.Italic = False
            If InStr(1, Rng.Value, "Poaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Poaceae"), Len("Poaceae")).Font.Italic = False
            If InStr(1, Rng.Value, "Polygonaceae") > 0 Then Rng.Characters(InStr(1, Rng.Value, "Polygonaceae"), Len("Polygonaceae")).Font.Italic = False
        i = i + 1
        Loop
        '--- ajouts des sous-titres
        sTitre = ""
        i = 31
        Do While .Range("A" & i).Value <> ""            '--- parcourt la liste jusqu'à tomber sur celule vide
            If .Range("F" & i).Value <> sTitre Then
                sTitre = .Range("F" & i).Value
                .Range("A" & i).EntireRow.Insert shift:=-4121, CopyOrigin:=1    '<-- 1 sans doute préférable à 0
                .Range("B" & i).Value = sTitre
                .Range("B" & i).Font.Bold = True
                .Range("B" & i).Font.Italic = False
            End If
            i = i + 1
        Loop
    End With
 
' fermeture des instances ouvertes
    oRst.Close
    xlWb.Close True
    Set oRst = Nothing
    Set oDb = Nothing
    Set Rng = Nothing
    Set xlWsTmp = Nothing
    Set xlWs = Nothing
    Set xlWb = Nothing
    Set xlApp = Nothing
End Sub

Je ne pensais pas que c'était possible d'obtenir un tel résultat et je m'étais resignée à faire tout cela manuellement, un travail très chronophage (j'ai quelques centaines de tableaux à produire). Jusque là, le tableau obtenu est très satisfaisant. Mais en réalité, il n'est pas fini, car il doit contenir des totaux, des pourcentages et des fréquences.
Je voudrais donc vous demander si vous considérez que c'est possible d'automatiser ce travail au maximum, par le biais de ce code sur lequel on travaille. En effet, faire ces manipulations manuellement représente des semaines de travail.
-Pour commencer, j'aurais besoin de créer une ligne, à la fin du tableau, avec les totaux pour chaque colonne à partir de la colonne G. Il faudrait que les totaux s'affichent en gras.
-Ensuite, j'aurais besoin de créer une colonne, à la fin du tableau, avec les totaux pour chaque ligne à partir de la ligne 32. Il faudrait que les totaux s'affichent en gras.
J'ai vu qu'il existe la fonction WorksheetFunction.Sum et j'ai essayé de l'adapter à mon code sans succès. Je ne sais pas vraiment comment m'y prendre.
Encore un grand merci pour le temps que vous consacrez à répondre à mes questions.
Cordialement,

[EricDgn]

C'est tout à fait possible, mais un point à préciser: avez-vous l'intention de faire des sous-totaux par catégorie ou pas (A. Céréales, B. ...) ?
Cordialement.

[Salo15]

C'est tout à fait possible, mais un point à préciser: avez-vous l'intention de faire des sous-totaux par catégorie ou pas (A. Céréales, B. ...) ?
Cordialement.

C'est une très bonne nouvelle ! Pour répondre à la question, non, je ne souhaite pas faire de sous-totaux par catégorie.