Transposer une table Access vers Excel avec VBA

**EricDgn** · 19/10/2020, 16h57

A tester, ajouter ceci entre les lignes 133 et 134:

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
' --- Loop
        Dim j As Long
        Dim sRng As String
        '--- ajout totaux en dernière ligne                     '--- i = n° ligne vide en bas du tableau
        j = .Range("G28").end(-4161).Column                     '--- n° dernière colonne non vide de la ligne n°28 --- xlToRight = -4161
        sRng = .Range(.Cells(29, 7), .Cells(i - 1, 7)).Address  '--- 7 = colonne G
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        .Range(.Cells(i, 7), .Cells(i, j)).Formula = "=SUM(" & sRng & ")"
        .Range(.Cells(i, 7), .Cells(i, j)).Font.Bold = True
        '--- ajout totaux en dernière colonne
        j = j + 1
        i = i - 1
        sRng = .Range(.Cells(29, 7), .Cells(29, j - 1)).Address '--- 29 = n° première ligne à sommer
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        .Range(.Cells(29, j), .Cells(i, j)).Formula = "=SUM(" & sRng & ")"
        .Range(.Cells(29, j), .Cells(i, j)).Font.Bold = True
' --- End With

En ajoutant la formule Somme() vous pourrez facilement vérifier d'un clic sur une cellule de total que ce total couvre bien la plage à prendre en compte.
Cordialement.

**Salo15** · 19/10/2020, 19h35

Envoyé par EricDgn

A tester, ajouter ceci entre les lignes 133 et 134:

En ajoutant la formule Somme() vous pourrez facilement vérifier d'un clic sur une cellule de total que ce total couvre bien la plage à prendre en compte.
Cordialement.

Bonsoir,
Merci ! ça marche parfaitement.
J'ai rajouté deux lignes dans l'en-tête du tableau, du coup j'ai modifié les cellules à partir desquelles je voulais obtenir les totaux. Voici mon dernier 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
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
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
 
    Dim j As Long
        Dim sRng As String
        '--- ajout totaux en dernière ligne                     '--- i = n° ligne vide en bas du tableau
        j = .Range("G30").End(-4161).Column                     '--- n° dernière colonne non vide de la ligne n°30 --- xlToRight = -4161
        sRng = .Range(.Cells(32, 7), .Cells(i - 1, 7)).Address  '--- 7 = colonne G
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        .Range(.Cells(i, 7), .Cells(i, j)).Formula = "=SUM(" & sRng & ")"
        .Range(.Cells(i, 7), .Cells(i, j)).Font.Bold = True
        '--- ajout totaux en dernière colonne
        j = j + 1
        i = i - 1
        sRng = .Range(.Cells(32, 7), .Cells(32, j - 1)).Address '--- 32 = n° première ligne à sommer
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        .Range(.Cells(32, j), .Cells(i, j)).Formula = "=SUM(" & sRng & ")"
        .Range(.Cells(32, j), .Cells(i, j)).Font.Bold = True
 
    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

Alors, vous trouverez dans l'image (en rouge) ce que je souhaiterais obtenir maintenant.
- Serait-il possible de faire la somme de la colonne de totaux, afin d'obtenir le total des carporestes de tous les échantillons (cellule J42 dans l'exemple) ?

- Ensuite, serait-il possible de prendre ce total afin de créer des pourcentages en gras dans la colonne suivante (colonne K dans l'exemple) ? Ici, il y a une condition à rajouter :
si la valeur du pourcentage se situe entre 0,1% et 0,49% au lieu d'afficher le chiffre, afficher "r"
si la valeur du pourcentage se situe entre 0,5% et 0,99% au lieu d'afficher le chiffre, afficher "+"

- Accessoirement, serait-il possible de rajouter en gras et centrés les titres qui s'affichent dans les cellules B42 ("Total NMI"), J31 ("Total NMI") et K31 ("21 = 100%, c-à-d "valeur du total de carporestes = 100%) ?

Encore un grand merci !

**EricDgn** · 20/10/2020, 10h54

Bonjour,
A tester. Les parties ajouts des totaux et des pourcentages ont été placées avant la partie ajout des sous-titres pour ne rien calculer au niveau de ces sous-titres.

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
170
171
172
173
174
175
176
177
178
179
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 xlWsTmp As Object
Dim i As Long
Dim j As Long
Dim Rng As Object
Dim sRng As String
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
 
        '--- ajout totaux en dernière ligne                     '--- i = n° ligne vide en bas du tableau
        j = .Range("G30").End(-4161).Column                     '--- n° dernière colonne non vide de la ligne n°30 --- xlToRight = -4161
        sRng = .Range(.Cells(32, 7), .Cells(i - 1, 7)).Address  '--- 7 = colonne G
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        .Range(.Cells(i, 7), .Cells(i, j + 2)).Formula = "=SUM(" & sRng & ")"
        .Cells(i, 2).Value = "Total NMI"
        .Range(.Cells(i, 1), .Cells(i, j) + 2).Font.Bold = True
 
        '--- ajout totaux en dernière colonne
        j = j + 1                                               '--- n° colonne
        i = i - 1                                               '--- n° dernière ligne de données
        .Cells(30, j).Value = "Total NMI"
        .Cells(30, j).HorizontalAlignment = -4108               '--- -4108 = xlCenter
        sRng = .Range(.Cells(32, 7), .Cells(32, j - 1)).Address '--- 32 = n° première ligne à sommer
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        .Range(.Cells(32, j), .Cells(i, j)).Formula = "=SUM(" & sRng & ")"
        .Range(.Cells(32, j), .Cells(i, j)).Font.Bold = True
 
        '--- ajout pourcentages en dernière colonne
        j = j + 1                                               '--- n° colonne
        .Cells(30, j).Value = .Cells(i + 1, j - 1).Value & " = 100%"
        .Cells(30, j).HorizontalAlignment = -4108               '--- -4108 = xlCenter
        sRng = .Cells(32, j - 1).Address
        sRng = Replace(sRng, "$", "")
        sRng = sRng & "/" & .Cells(i + 1, j - 1).Address
        .Range(.Cells(32, j), .Cells(i, j)).Formula = "=" & sRng
        .Range(.Cells(32, j), .Cells(i, j)).NumberFormat = "0%" '--- ou "0.0%" pour avoir 1 décimale
        .Range(.Cells(32, j), .Cells(i, j)).Bold = True
 
        '--- 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

Cordialement.

**Salo15** · 20/10/2020, 15h26

Envoyé par EricDgn

Bonjour,
A tester. Les parties ajouts des totaux et des pourcentages ont été placées avant la partie ajout des sous-titres pour ne rien calculer au niveau de ces sous-titres.

Cordialement.

Bonjour,

Je vous remercie pour votre aide. Après quelques corrections, ça marche !
- Il y avait un problème avec un point au niveau de la ligne 131, c'est réglé.
- Il y avait un problème avec une parenthèse au niveau de la ligne 141, c'est réglé.
- Il y avait un problème car quelques cellules des colonnes A à F se mettaient en gras sans raison apparente, ou le titre "Total NMI" de la dernière ligne se mettait en italique, sans doute car la cellule se trouve à la suite de la liste des taxons. Plus embêtant, quand j'exportais un tableau avec plus de colonnes que le précèdent, les cellules restaient avec le format "pourcentage" et les chiffres du nombre des carporestes de l'échantillon s'affichaient en pourcentages au milieu du tableau. Du coup, j'ai rajouté la ligne 47 xlWs.Cells.ClearFormats tel que vous l'aviez suggéré il y a quelques jours et le problème est réglé.
- Il y avait un problème avec la somme et le pourcentage de la première ligne. En effet, elle n'était pas prise en compte. Dans le code on demandait de faire ces opérations à partir de la ligne 32 (c'est en effet à partir de la ligne 32 que les totaux doivent apparaître), mais en ayant la ligne des sous-titres qui vient se rajouter après, du coup la ligne 32 n'était pas prise en compte, j'ai donc modifié la plage et mettant ligne 31 au lieu de ligne 32 dans les lignes 127, 138, 140, 141, 150, 151 et 152 et ça marche.

Sinon, je vous remercie infiniment d'avoir pris l'initiative de ne pas afficher les sommes et les pourcentages dans les lignes des sous-titres des catégories. Je n'avais pas osé vous le demander de peur que ce soit trop compliqué.

Voici le nouveau 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
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
170
171
172
173
174
175
176
177
178
179
180
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 xlWsTmp As Object
Dim i As Long
Dim j As Long
Dim Rng As Object
Dim sRng As String
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
    xlWs.Cells.ClearFormats
 
    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
 
        '--- ajout totaux en dernière ligne                     '--- i = n° ligne vide en bas du tableau
        j = .Range("G30").End(-4161).Column                     '--- n° dernière colonne non vide de la ligne n°30 --- xlToRight = -4161
        sRng = .Range(.Cells(31, 7), .Cells(i - 1, 7)).Address  '--- 7 = colonne G
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        .Range(.Cells(i, 7), .Cells(i, j + 2)).Formula = "=SUM(" & sRng & ")"
        .Cells(i, 2).Value = "Total NMI"
        .Range(.Cells(i, 1), .Cells(i, j + 2)).Font.Bold = True
 
        '--- ajout totaux en dernière colonne
        j = j + 1                                               '--- n° colonne
        i = i - 1                                               '--- n° dernière ligne de données
        .Cells(30, j).Value = "Total NMI"
        .Cells(30, j).HorizontalAlignment = -4108               '--- -4108 = xlCenter
        sRng = .Range(.Cells(31, 7), .Cells(31, j - 1)).Address '--- 32 = n° première ligne à sommer
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        .Range(.Cells(31, j), .Cells(i, j)).Formula = "=SUM(" & sRng & ")"
        .Range(.Cells(31, j), .Cells(i, j)).Font.Bold = True
 
        '--- ajout pourcentages en dernière colonne
        j = j + 1                                               '--- n° colonne
        .Cells(30, j).Value = .Cells(i + 1, j - 1).Value & " = 100%"
        .Cells(30, j).HorizontalAlignment = -4108               '--- -4108 = xlCenter
        sRng = .Cells(31, j - 1).Address
        sRng = Replace(sRng, "$", "")
        sRng = sRng & "/" & .Cells(i + 1, j - 1).Address
        .Range(.Cells(31, j), .Cells(i, j)).Formula = "=" & sRng
        .Range(.Cells(31, j), .Cells(i, j)).NumberFormat = "0%" '--- ou "0.0%" pour avoir 1 décimale
        .Range(.Cells(31, j), .Cells(i, j)).Font.Bold = True
 
        '--- 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

Si vous le permettez, j'ai encore quelques demandes mais je vous les ferai au fur et à mesure. Pour commencer :

- Serait-il possible de rajouter la condition suivante à appliquer dans la colonne pourcentages ?
si la valeur du pourcentage se situe entre 0,1% et 0,49% au lieu d'afficher le chiffre, afficher "r"
si la valeur du pourcentage se situe entre 0,5% et 0,99% au lieu d'afficher le chiffre, afficher "+"

- Serait-il possible de fusionner toutes les cellules de chacune des lignes où apparaissent les sous-titres des catégories?

- Du fait que j'ai rajouté la ligné xlWs.Cells.ClearFormats, serait-il possible de mettre tout le tableau en Arial 10 avant de fermer le code ?

Merci par avance,
Cordialement.

**EricDgn** · 20/10/2020, 17h49

A tester/adapter/corriger:
lignes 50-52: police Arial 10
lignes 155-158: formule pour pourcentages
lignes 172-173: fusion sous-titre

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
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
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 xlWsTmp As Object
Dim i As Long
Dim j As Long
Dim Rng As Object
Dim sRng As String
Dim sFml As String
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
    With xlWs.Cells
        .ClearContents
        .ClearFormats
        .Font.Name = "Arial"        '--- ou Arial Narrow ?
        .Font.Size = 10
    End With
 
    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
 
        '--- ajout totaux en dernière ligne                     '--- i = n° ligne vide en bas du tableau
        j = .Range("G30").end(-4161).Column                     '--- n° dernière colonne non vide de la ligne n°30 --- xlToRight = -4161
        sRng = .Range(.Cells(31, 7), .Cells(i - 1, 7)).Address  '--- 7 = colonne G
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        .Range(.Cells(i, 7), .Cells(i, j + 2)).Formula = "=SUM(" & sRng & ")"
        .Cells(i, 2).Value = "Total NMI"
        .Range(.Cells(i, 1), .Cells(i, j + 2)).Font.Bold = True
 
        '--- ajout totaux en dernière colonne
        j = j + 1                                               '--- n° colonne
        i = i - 1                                               '--- n° dernière ligne de données
        .Cells(30, j).Value = "Total NMI"
        .Cells(30, j).HorizontalAlignment = -4108               '--- -4108 = xlCenter
        sRng = .Range(.Cells(31, 7), .Cells(31, j - 1)).Address '--- 32 = n° première ligne à sommer
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        .Range(.Cells(31, j), .Cells(i, j)).Formula = "=SUM(" & sRng & ")"
        .Range(.Cells(31, j), .Cells(i, j)).Font.Bold = True
 
        '--- ajout pourcentages en dernière colonne
        j = j + 1                                               '--- n° colonne
        .Cells(30, j).Value = .Cells(i + 1, j - 1).Value & " = 100%"
        .Cells(30, j).HorizontalAlignment = -4108               '--- -4108 = xlCenter
        sRng = .Cells(31, j - 1).Address
        sRng = Replace(sRng, "$", "")
        sRng = sRng & "/" & .Cells(i + 1, j - 1).Address        '--- le rapport
        sFml = "=If(Rng<0.005,'r', If(Rng<0.01,'+',Rng))"       '--- modèle de la formule --- 0.005 = 5% --- 0.01 = 1%
        sFml = Replace(sFml, "Rng", sRng)                       '--- remplace Rng par sRng (rapport)
        sFml = Replace(sFml, "'", Chr(34))                      '--- remplace les ' par "
        .Range(.Cells(31, j), .Cells(i, j)).Formula = sFml
        .Range(.Cells(31, j), .Cells(i, j)).NumberFormat = "0%" '--- ou "0.0%" pour avoir 1 décimale
        .Range(.Cells(31, j), .Cells(i, j)).Font.Bold = True
 
        '--- 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
                .Range(.Cells(i, 2), .Cells(i, j)).Merge                        '--- j = n° colonne pourcentages
                .Range(.Cells(i, 2), .Cells(i, j)).HorizontalAlignment = -4131  '--- xlLeft= -4131, xlCenter= -4108
            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** · 21/10/2020, 02h19

Envoyé par EricDgn

A tester/adapter/corriger:
lignes 50-52: police Arial 10
lignes 155-158: formule pour pourcentages
lignes 172-173: fusion sous-titre
Cordialement.

Bonjour,

Je ne vous remercierai jamais assez pour toute votre aide. Le code marche parfaitement.
J'ai rajouté une colonne et bougé la colonne "Catégories" de place, du coup j'ai adapté le code et ça marche !

Voici le dernier 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
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
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
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 xlWsTmp As Object
Dim i As Long
Dim j As Long
Dim Rng As Object
Dim sRng As String
Dim sFml As String
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
    With xlWs.Cells
        .ClearContents
        .ClearFormats
        .Font.Name = "Arial"   '--- ou Arial Narrow ?
        .Font.Size = 10
        .HorizontalAlignment = -4108                        '--- xlCenter= -4108
        xlWs.Columns("A:G").HorizontalAlignment = -4131     '--- xlLeft= -4131
 
    End With
 
    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("G1").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
 
        '--- ajout totaux en dernière ligne                     '--- i = n° ligne vide en bas du tableau
        j = .Range("H30").End(-4161).Column                     '--- n° dernière colonne non vide de la ligne n°30 --- xlToRight = -4161
        sRng = .Range(.Cells(31, 8), .Cells(i - 1, 8)).Address  '--- 8 = colonne H
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        .Range(.Cells(i, 8), .Cells(i, j + 2)).Formula = "=SUM(" & sRng & ")"
        .Cells(i, 2).Value = "Total NMI"
        .Range(.Cells(i, 1), .Cells(i, j + 2)).Font.Bold = True
 
        '--- ajout totaux en dernière colonne
        j = j + 1                                               '--- n° colonne
        i = i - 1                                               '--- n° dernière ligne de données
        .Cells(30, j).Value = "Total NMI"
        .Cells(30, j).HorizontalAlignment = -4108               '--- -4108 = xlCenter
        sRng = .Range(.Cells(31, 8), .Cells(31, j - 1)).Address '--- 31 = n° première ligne à sommer
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        .Range(.Cells(31, j), .Cells(i, j)).Formula = "=SUM(" & sRng & ")"
        .Range(.Cells(31, j), .Cells(i, j)).Font.Bold = True
 
        '--- ajout pourcentages en dernière colonne
        j = j + 1                                               '--- n° colonne
        .Cells(30, j).Value = .Cells(i + 1, j - 1).Value & " = 100%"
        .Cells(30, j).HorizontalAlignment = -4108               '--- -4108 = xlCenter
        sRng = .Cells(31, j - 1).Address
        sRng = Replace(sRng, "$", "")
        sRng = sRng & "/" & .Cells(i + 1, j - 1).Address        '--- le rapport
        sFml = "=If(Rng<0.005,'r', If(Rng<0.01,'+',Rng))"       '--- modèle de la formule --- 0.005 = 5% --- 0.01 = 1%
        sFml = Replace(sFml, "Rng", sRng)                       '--- remplace Rng par sRng (rapport)
        sFml = Replace(sFml, "'", Chr(34))                      '--- remplace les " par "
        .Range(.Cells(31, j), .Cells(i, j)).Formula = sFml
        .Range(.Cells(31, j), .Cells(i, j)).NumberFormat = "0%" '--- ou "0.0%" pour avoir 1 décimale
        .Range(.Cells(31, j), .Cells(i, j)).Font.Bold = True
 
        '--- ajouts des sous-titres
        sTitre = ""
        i = 31
        Do While .Range("A" & i).Value <> ""            '--- parcourt la liste jusqu'à tomber sur celule vide
            If .Range("D" & i).Value <> sTitre Then
                sTitre = .Range("D" & 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
                .Range(.Cells(i, 2), .Cells(i, j)).Merge                        '--- j = n° colonne pourcentages
            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

Si vous permettez, j'ai encore trois choses à vous demander :

- Serait-il possible de rajouter une "bordure en haut et en bas" dans la dernière ligne du tableau (voir image) ?

- Dans la colonne à droite des pourcentages, je souhaiterais obtenir une colonne qui affiche le taux de fréquence des carporestes dans les échantillons. Seule chose, il faudrait que ces fréquences soient calculées par "regroupement" des taxons (définis dans la colonne C). Autrement dit, il faudrait diviser le nombre d'échantillons dans lequel un "regroupement" est présent par le nombre total d'échantillons, ensuite il faudrait afficher le résultat dans la première ligne du regroupement et dans la dernière colonne.
Vous trouverez en image deux exemples. Je ne sais pas si ceci est possible. Il faudrait peut-être d'abord demander à calculer le nombre d'échantillons (nombre de colonnes à partir de H et jusqu'avant la colonne "Total NMI"). Ensuite il faudrait peut-être demander à choisir la plage où se trouvent toutes les lignes appartenant au même "regroupement" (défini en colonne C), et demander ensuite de calculer le nombre de colonnes remplies ou vides afin de faire le calcul du nombre d'échantillons où se trouve le "regroupement", pour ensuite diviser ce dernier par le nombre total d'échantillons. Ensuite il faudrait exprimer le résultat en pourcentages. Je m'excuse si ce n'est pas très clair.

- Serait-il possible de supprimer les colonnes C et D avant la fermeture du code ?

Merci infiniment,
Cordialement.

**EricDgn** · 21/10/2020, 15h11

Voilà toujours pour ce qui est de la présentation:
- lignes 138-139: bordures haut et bas totaux
- lignes 182-183: masquer les colonnes C et D (vraiment pas indiqué de les supprimer).
Pour le calcul des fréquences, j'ai compris ce qui est à calculer, mais n'en ai pas encore la solution!

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
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
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 xlWsTmp As Object
Dim i As Long
Dim j As Long
Dim Rng As Object
Dim sRng As String
Dim sFml As String
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
    With xlWs.Cells
        .ClearContents
        .ClearFormats
        .Font.Name = "Arial"        '--- ou Arial Narrow ?
        .Font.Size = 10
    End With
 
    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
 
        '--- ajout totaux en dernière ligne                     '--- i = n° ligne vide en bas du tableau
        .Cells(i, 2).Value = "Total NMI"
        j = .Range("G30").End(-4161).Column                     '--- n° dernière colonne non vide de la ligne n°30 --- xlToRight = -4161
        sRng = .Range(.Cells(31, 7), .Cells(i - 1, 7)).Address  '--- 7 = colonne G
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        With .Range(.Cells(i, 1), .Cells(i, j + 2))
            .Formula = "=SUM(" & sRng & ")"
            .Font.Bold = True
            .Borders(8).Weight = 2         '--- xlEdgeTop = 8    --- xlThin = 2 --- xlMedium = -4138
            .Borders(9).Weight = 2         '--- xlEdgeBottom = 9
        End With
 
        '--- ajout totaux en dernière colonne
        j = j + 1                                               '--- n° colonne
        i = i - 1                                               '--- n° dernière ligne de données
        .Cells(30, j).Value = "Total NMI"
        .Cells(30, j).HorizontalAlignment = -4108               '--- -4108 = xlCenter
        sRng = .Range(.Cells(31, 7), .Cells(31, j - 1)).Address '--- 32 = n° première ligne à sommer
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        .Range(.Cells(31, j), .Cells(i, j)).Formula = "=SUM(" & sRng & ")"
        .Range(.Cells(31, j), .Cells(i, j)).Font.Bold = True
 
        '--- ajout pourcentages en dernière colonne
        j = j + 1                                               '--- n° colonne
        .Cells(30, j).Value = .Cells(i + 1, j - 1).Value & " = 100%"
        .Cells(30, j).HorizontalAlignment = -4108               '--- -4108 = xlCenter
        sRng = .Cells(31, j - 1).Address
        sRng = Replace(sRng, "$", "")
        sRng = sRng & "/" & .Cells(i + 1, j - 1).Address        '--- le rapport
        sFml = "=If(Rng<0.005,'r', If(Rng<0.01,'+',Rng))"       '--- modèle de la formule --- 0.005 = 5% --- 0.01 = 1%
        sFml = Replace(sFml, "Rng", sRng)                       '--- remplace Rng par sRng (rapport)
        sFml = Replace(sFml, "'", Chr(34))                      '--- remplace les ' par "
        .Range(.Cells(31, j), .Cells(i, j)).Formula = sFml
        .Range(.Cells(31, j), .Cells(i, j)).NumberFormat = "0%" '--- ou "0.0%" pour avoir 1 décimale
        .Range(.Cells(31, j), .Cells(i, j)).Font.Bold = True
 
        '--- 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
                .Range(.Cells(i, 2), .Cells(i, j)).Merge                        '--- j = n° colonne pourcentages
                .Range(.Cells(i, 2), .Cells(i, j)).HorizontalAlignment = -4131  '--- xlLeft= -4131, xlCenter= -4108
            End If
            i = i + 1
        Loop
 
        '--- masquer colonnes C et D
        .Columns("C:D").EntireColumn.Hidden = True
 
    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.

**EricDgn** · 21/10/2020, 16h51

A tester. La fréquence est calculée par une procédure annexe (lignes 202-234) appelée à la ligne 167.

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
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
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 xlWsTmp As Object
Dim i As Long
Dim j As Long
Dim Rng As Object
Dim sRng As String
Dim sFml As String
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
    With xlWs.Cells
        .ClearContents
        .ClearFormats
        .Font.Name = "Arial"        '--- ou Arial Narrow ?
        .Font.Size = 10
    End With
 
    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
 
        '--- ajout totaux en dernière ligne                     '--- i = n° ligne vide en bas du tableau
        .Cells(i, 2).Value = "Total NMI"
        j = .Range("G30").End(-4161).Column                     '--- n° dernière colonne non vide de la ligne n°30 --- xlToRight = -4161
        sRng = .Range(.Cells(31, 7), .Cells(i - 1, 7)).Address  '--- 7 = colonne G
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        With .Range(.Cells(i, 1), .Cells(i, j + 2))
            .Formula = "=SUM(" & sRng & ")"
            .Font.Bold = True
            .Borders(8).Weight = 2         '--- xlEdgeTop = 8    --- xlThin = 2 --- xlMedium = -4138
            .Borders(9).Weight = 2         '--- xlEdgeBottom = 9
        End With
 
        '--- ajout totaux en dernière colonne
        j = j + 1                                               '--- n° colonne
        i = i - 1                                               '--- n° dernière ligne de données
        .Cells(30, j).Value = "Total NMI"
        .Cells(30, j).HorizontalAlignment = -4108               '--- -4108 = xlCenter
        sRng = .Range(.Cells(31, 7), .Cells(31, j - 1)).Address '--- 32 = n° première ligne à sommer
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        .Range(.Cells(31, j), .Cells(i, j)).Formula = "=SUM(" & sRng & ")"
        .Range(.Cells(31, j), .Cells(i, j)).Font.Bold = True
 
        '--- ajout pourcentages en dernière colonne
        j = j + 1                                               '--- n° colonne pourcentage
        .Cells(30, j).Value = .Cells(i + 1, j - 1).Value & " = 100%"
        .Cells(30, j).HorizontalAlignment = -4108               '--- -4108 = xlCenter
        sRng = .Cells(31, j - 1).Address
        sRng = Replace(sRng, "$", "")
        sRng = sRng & "/" & .Cells(i + 1, j - 1).Address        '--- le rapport
        sFml = "=If(Rng<0.005,'r', If(Rng<0.01,'+',Rng))"       '--- modèle de la formule --- 0.005 = 5% --- 0.01 = 1%
        sFml = Replace(sFml, "Rng", sRng)                       '--- remplace Rng par sRng (rapport)
        sFml = Replace(sFml, "'", Chr(34))                      '--- remplace les ' par "
        .Range(.Cells(31, j), .Cells(i, j)).Formula = sFml
        .Range(.Cells(31, j), .Cells(i, j)).NumberFormat = "0%" '--- ou "0.0%" pour avoir 1 décimale
        .Range(.Cells(31, j), .Cells(i, j)).Font.Bold = True
 
        '--- ajouts fréquences
        Freq xlWs, j + 1
 
        '--- 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
                .Range(.Cells(i, 2), .Cells(i, j)).Merge                        '--- j = n° colonne pourcentages
                .Range(.Cells(i, 2), .Cells(i, j)).HorizontalAlignment = -4131  '--- xlLeft= -4131, xlCenter= -4108
            End If
            i = i + 1
        Loop
 
        '--- masquer colonnes C et D
        .Columns("C:D").EntireColumn.Hidden = True
 
    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
 
Private Sub Freq(R As Object, j As Long)
    Dim kR As Long, kC As Long
    Dim k(100) As Variant, n As Integer             '--- 100 = nombre maximal de colonnes dans la feuille
    Dim sGroupe As String, kRGroupe As Long
    kR = 30
    kRGroupe = kR
    sGroupe = ""
    With R
        .Cells(kR, j).Value = "Fréquence" & vbLf & (j - 10) & " = 100%"
        .Cells(kR, j).HorizontalAlignment = -4108
        While .Cells(kR - 1, 2).Value <> ""
            If .Cells(kR, 3).Value <> sGroupe Then  '--- nouveau groupe
                '--- résultat groupe précédent
                n = 0
                For kC = 8 To j - 3                 '--- 8 = première colonne de données
                    If k(kC) <> 0 Then n = n + 1    '--- nb de colonnes non nulles = nb de lieux
                    k(kC) = 0
                Next kC
                If sGroupe <> "" Then               '--- inscrit fréquence
                    .Cells(kRGroupe, j).Value = n / (j - 10)
                    .Cells(kRGroupe, j).Format = "0%"
                    .Cells(kRGroupe, j).HorizontalAlignment = -4108
                End If
                '--- début nouveau groupe
                kRGroupe = kR
                sGroupe = .Cells(kR, 3).Value
            End If
            '--- cumul par colonne/lieu pour le groupe en cours
            For kC = 8 To j - 3                     '--- 8 = première colonne de données, j-3 dernière colonne
                k(kC) = k(kC) + .Cells(kR, kC)
            Next kC
            kR = kR + 1
        Wend
    End With
End Sub

Cordialement.

**Salo15** · 21/10/2020, 17h10

Envoyé par EricDgn

Voilà toujours pour ce qui est de la présentation:
- lignes 138-139: bordures haut et bas totaux
- lignes 182-183: masquer les colonnes C et D (vraiment pas indiqué de les supprimer).
Pour le calcul des fréquences, j'ai compris ce qui est à calculer, mais n'en ai pas encore la solution!
Cordialement.

Bonjour,

Merci beaucoup. J'ai rencontré un problème avec l'ajout des lignes 138-139, mais j'ai adapté le code et ça marche.

Voici mon tout dernier 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
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
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
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 xlWsTmp As Object
Dim i As Long
Dim j As Long
Dim Rng As Object
Dim sRng As String
Dim sFml As String
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
    With xlWs.Cells
        .ClearContents
        .ClearFormats
        .Font.Name = "Arial"   '--- ou Arial Narrow ?
        .Font.Size = 10
        .HorizontalAlignment = -4108                        '--- xlCenter= -4108
        xlWs.Columns("A:G").HorizontalAlignment = -4131     '--- xlLeft= -4131
 
    End With
 
    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("G1").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
 
        '--- ajout totaux en dernière ligne                     '--- i = n° ligne vide en bas du tableau
        j = .Range("H30").End(-4161).Column                     '--- n° dernière colonne non vide de la ligne n°30 --- xlToRight = -4161
        sRng = .Range(.Cells(31, 8), .Cells(i - 1, 8)).Address  '--- 8 = colonne H
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        .Range(.Cells(i, 8), .Cells(i, j + 2)).Formula = "=SUM(" & sRng & ")"
        .Cells(i, 2).Value = "Total NMI"
        .Range(.Cells(i, 1), .Cells(i, j + 2)).Font.Bold = True
        .Range(.Cells(i, 1), .Cells(i, j + 2)).Borders(8).Weight = 2         '--- xlEdgeTop = 8    --- xlThin = 2 --- xlMedium = -4138
        .Range(.Cells(i, 1), .Cells(i, j + 2)).Borders(9).Weight = 2         '--- xlEdgeBottom = 9
 
        '--- ajout totaux en dernière colonne
        j = j + 1                                               '--- n° colonne
        i = i - 1                                               '--- n° dernière ligne de données
        .Cells(30, j).Value = "Total NMI"
        .Cells(30, j).HorizontalAlignment = -4108               '--- -4108 = xlCenter
        sRng = .Range(.Cells(31, 8), .Cells(31, j - 1)).Address '--- 31 = n° première ligne à sommer
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        .Range(.Cells(31, j), .Cells(i, j)).Formula = "=SUM(" & sRng & ")"
        .Range(.Cells(31, j), .Cells(i, j)).Font.Bold = True
 
        '--- ajout pourcentages en dernière colonne
        j = j + 1                                               '--- n° colonne
        .Cells(30, j).Value = .Cells(i + 1, j - 1).Value & " = 100%"
        .Cells(30, j).HorizontalAlignment = -4108               '--- -4108 = xlCenter
        sRng = .Cells(31, j - 1).Address
        sRng = Replace(sRng, "$", "")
        sRng = sRng & "/" & .Cells(i + 1, j - 1).Address        '--- le rapport
        sFml = "=If(Rng<0.005,'r', If(Rng<0.01,'+',Rng))"       '--- modèle de la formule --- 0.005 = 5% --- 0.01 = 1%
        sFml = Replace(sFml, "Rng", sRng)                       '--- remplace Rng par sRng (rapport)
        sFml = Replace(sFml, "'", Chr(34))                      '--- remplace les " par "
        .Range(.Cells(31, j), .Cells(i, j)).Formula = sFml
        .Range(.Cells(31, j), .Cells(i, j)).NumberFormat = "0%" '--- ou "0.0%" pour avoir 1 décimale
        .Range(.Cells(31, j), .Cells(i, j)).Font.Bold = True
 
        '--- ajouts des sous-titres
        sTitre = ""
        i = 31
        Do While .Range("A" & i).Value <> ""            '--- parcourt la liste jusqu'à tomber sur celule vide
            If .Range("D" & i).Value <> sTitre Then
                sTitre = .Range("D" & 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
                .Range(.Cells(i, 2), .Cells(i, j)).Merge                        '--- j = n° colonne pourcentages
            End If
            i = i + 1
        Loop
 
        '--- masquer colonnes C et D
        .Columns("C:D").EntireColumn.Hidden = True
 
    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

En ce qui concerne le calcul des fréquences, si ça peut nous aider à réfléchir à une solution, je vous explique les manipulations que je faisais jusqu'à présente avec chacun de mes tableaux (manuellement).

- dans une plage vide de ma feuille, je lance la fonction "NB" et je choisis les cellules concernées pour chacune des colonnes (échantillons) et des "regroupements" des taxons. J'obtiens ainsi une ligne pour chaque regroupement et une colonne pour chaque échantillon.
- ensuite je lance la fonction "NB.SI" et je choisis toute la ligne qui correspond au regroupement du taxon. J'obtiens ainsi le nombre de colonnes remplies et ensuite je transforme ce résultat en pourcentage.
Je vous joins un fichier Excel avec un exemple (regardez à partir de la ligne 68)

Cordialement,

**EricDgn** · 21/10/2020, 17h58

La procédure Freq() procède en pratique de la même façon que celle que vous avez utilisée, mais en mettant les sommes intermédiaires dans le tableau k().
Cordialement.

**Salo15** · 21/10/2020, 18h02

Envoyé par EricDgn

La procédure Freq() procède en pratique de la même façon que celle que vous avez utilisée, mais en mettant les sommes intermédiaires dans le tableau k().
Cordialement.

Merci beaucoup, je vous ai envoyé le dernier message car je n'avais pas vu votre message précèdent. Je vais tester et je reviens vers vous !

Cordialement,

**Salo15** · 21/10/2020, 19h45

Envoyé par EricDgn

A tester. La fréquence est calculée par une procédure annexe (lignes 202-234) appelée à la ligne 167.
Cordialement.

Bonsoir,
J'ai testé mais il y a juste une partie qui marche. Le titre apparaît bien à sa place mais pas les résultats des calculs (voir image). Là pour le coup je ne sais pas d'où vient le problème car il n'y a aucun avertissement qui s'affiche.

Voici le dernier code actualisé :

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
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
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 xlWsTmp As Object
Dim i As Long
Dim j As Long
Dim Rng As Object
Dim sRng As String
Dim sFml As String
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
    With xlWs.Cells
        .ClearContents
        .ClearFormats
        .Font.Name = "Arial"   '--- ou Arial Narrow ?
        .Font.Size = 10
        .HorizontalAlignment = -4108                        '--- xlCenter= -4108
        xlWs.Columns("A:G").HorizontalAlignment = -4131     '--- xlLeft= -4131
 
    End With
 
    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("G1").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
 
        '--- ajout totaux en dernière ligne                     '--- i = n° ligne vide en bas du tableau
        j = .Range("H30").End(-4161).Column                     '--- n° dernière colonne non vide de la ligne n°30 --- xlToRight = -4161
        sRng = .Range(.Cells(31, 8), .Cells(i - 1, 8)).Address  '--- 8 = colonne H
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        .Range(.Cells(i, 8), .Cells(i, j + 2)).Formula = "=SUM(" & sRng & ")"
        .Cells(i, 2).Value = "Total NMI"
        .Range(.Cells(i, 1), .Cells(i, j + 2)).Font.Bold = True
        .Range(.Cells(i, 1), .Cells(i, j + 2)).Borders(8).Weight = 2         '--- xlEdgeTop = 8    --- xlThin = 2 --- xlMedium = -4138
        .Range(.Cells(i, 1), .Cells(i, j + 2)).Borders(9).Weight = 2         '--- xlEdgeBottom = 9
 
        '--- ajout totaux en dernière colonne
        j = j + 1                                               '--- n° colonne
        i = i - 1                                               '--- n° dernière ligne de données
        .Cells(30, j).Value = "Total NMI"
        .Cells(30, j).HorizontalAlignment = -4108               '--- -4108 = xlCenter
        sRng = .Range(.Cells(31, 8), .Cells(31, j - 1)).Address '--- 31 = n° première ligne à sommer
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        .Range(.Cells(31, j), .Cells(i, j)).Formula = "=SUM(" & sRng & ")"
        .Range(.Cells(31, j), .Cells(i, j)).Font.Bold = True
 
        '--- ajout pourcentages en dernière colonne
        j = j + 1                                               '--- n° colonne
        .Cells(30, j).Value = .Cells(i + 1, j - 1).Value & " = 100%"
        .Cells(30, j).HorizontalAlignment = -4108               '--- -4108 = xlCenter
        sRng = .Cells(31, j - 1).Address
        sRng = Replace(sRng, "$", "")
        sRng = sRng & "/" & .Cells(i + 1, j - 1).Address        '--- le rapport
        sFml = "=If(Rng<0.005,'r', If(Rng<0.01,'+',Rng))"       '--- modèle de la formule --- 0.005 = 5% --- 0.01 = 1%
        sFml = Replace(sFml, "Rng", sRng)                       '--- remplace Rng par sRng (rapport)
        sFml = Replace(sFml, "'", Chr(34))                      '--- remplace les " par "
        .Range(.Cells(31, j), .Cells(i, j)).Formula = sFml
        .Range(.Cells(31, j), .Cells(i, j)).NumberFormat = "0%" '--- ou "0.0%" pour avoir 1 décimale
        .Range(.Cells(31, j), .Cells(i, j)).Font.Bold = True
 
        '--- ajouts fréquences
        Freq xlWs, j + 1
 
        '--- ajouts des sous-titres
        sTitre = ""
        i = 31
        Do While .Range("A" & i).Value <> ""            '--- parcourt la liste jusqu'à tomber sur celule vide
            If .Range("D" & i).Value <> sTitre Then
                sTitre = .Range("D" & 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
                .Range(.Cells(i, 2), .Cells(i, j)).Merge                        '--- j = n° colonne pourcentages
            End If
            i = i + 1
        Loop
 
        '--- masquer colonnes C et D
        .Columns("C:D").EntireColumn.Hidden = True
 
    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
 
Private Sub Freq(R As Object, j As Long)
    Dim kR As Long, kC As Long
    Dim k(100) As Variant, n As Integer             '--- 100 = nombre maximal de colonnes dans la feuille
    Dim sGroupe As String, kRGroupe As Long
    kR = 30
    kRGroupe = kR
    sGroupe = ""
    With R
        .Cells(kR, j).Value = "Fréquence" & vbLf & (j - 10) & " = 100%"
        .Cells(kR, j).HorizontalAlignment = -4108
        While .Cells(kR - 1, 2).Value <> ""
            If .Cells(kR, 3).Value <> sGroupe Then  '--- nouveau groupe
                '--- résultat groupe précédent
                n = 0
                For kC = 8 To j - 3                 '--- 8 = première colonne de données
                    If k(kC) <> 0 Then n = n + 1    '--- nb de colonnes non nulles = nb de lieux
                    k(kC) = 0
                Next kC
                If sGroupe <> "" Then               '--- inscrit fréquence
                    .Cells(kRGroupe, j).Value = n / (j - 10)
                    .Cells(kRGroupe, j).Format = "0%"
                    .Cells(kRGroupe, j).HorizontalAlignment = -4108
                End If
                '--- début nouveau groupe
                kRGroupe = kR
                sGroupe = .Cells(kR, 3).Value
            End If
            '--- cumul par colonne/lieu pour le groupe en cours
            For kC = 8 To j - 3                     '--- 8 = première colonne de données, j-3 dernière colonne
                k(kC) = k(kC) + .Cells(kR, kC)
            Next kC
            kR = kR + 1
        Wend
    End With
End Sub

Merci par avance,
Cordialement.

**EricDgn** · 21/10/2020, 20h55

Voilà, 2e essai!
et ligne 159 modifié pour que si Total = 0, inscrit un -.

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
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
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 xlWsTmp As Object
Dim i As Long
Dim j As Long
Dim Rng As Object
Dim sRng As String
Dim sFml As String
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
    With xlWs.cells
        .ClearContents
        .ClearFormats
        .Font.Name = "Arial"        '--- ou Arial Narrow ?
        .Font.Size = 10
    End With
 
    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
 
        '--- ajout totaux en dernière ligne                     '--- i = n° ligne vide en bas du tableau
        .cells(i, 2).Value = "Total NMI"
        j = .Range("G30").End(-4161).Column                     '--- n° dernière colonne non vide de la ligne n°30 --- xlToRight = -4161
        sRng = .Range(.cells(31, 7), .cells(i - 1, 7)).Address  '--- 7 = colonne G
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        With .Range(.cells(i, 1), .cells(i, j + 2))
            .Formula = "=SUM(" & sRng & ")"
            .Font.Bold = True
            .Borders(8).Weight = 2         '--- xlEdgeTop = 8    --- xlThin = 2 --- xlMedium = -4138
            .Borders(9).Weight = 2         '--- xlEdgeBottom = 9
        End With
 
        '--- ajout totaux en dernière colonne
        j = j + 1                                               '--- n° colonne
        i = i - 1                                               '--- n° dernière ligne de données
        .cells(30, j).Value = "Total NMI"
        .cells(30, j).HorizontalAlignment = -4108               '--- -4108 = xlCenter
        sRng = .Range(.cells(31, 7), .cells(31, j - 1)).Address '--- 32 = n° première ligne à sommer
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        .Range(.cells(31, j), .cells(i, j)).Formula = "=SUM(" & sRng & ")"
        .Range(.cells(31, j), .cells(i, j)).Font.Bold = True
 
        '--- ajout pourcentages en dernière colonne
        j = j + 1                                               '--- n° colonne pourcentage
        .cells(30, j).Value = .cells(i + 1, j - 1).Value & " = 100%"
        .cells(30, j).HorizontalAlignment = -4108               '--- -4108 = xlCenter
        sRng = .cells(31, j - 1).Address
        sRng = Replace(sRng, "$", "")
        sRng = sRng & "/" & .cells(i + 1, j - 1).Address                '--- le rapport
        sFml = "=If(Rng=0,'-',If(Rng<0.005,'r', If(Rng<0.01,'+',Rng)))" '--- modèle de la formule --- 0.005 = 5% --- 0.01 = 1%
        sFml = Replace(sFml, "Rng", sRng)                       '--- remplace Rng par sRng (rapport)
        sFml = Replace(sFml, "'", Chr(34))                      '--- remplace les ' par "
        .Range(.cells(31, j), .cells(i, j)).Formula = sFml
        .Range(.cells(31, j), .cells(i, j)).numberFormat = "0%" '--- ou "0.0%" pour avoir 1 décimale
        .Range(.cells(31, j), .cells(i, j)).Font.Bold = True
 
        '--- ajouts fréquences
        Freq xlWs, j + 1
 
        '--- 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
                .Range(.cells(i, 2), .cells(i, j)).Merge                        '--- j = n° colonne pourcentages
                .Range(.cells(i, 2), .cells(i, j)).HorizontalAlignment = -4131  '--- xlLeft= -4131, xlCenter= -4108
            End If
            i = i + 1
        Loop
 
        '--- masquer colonnes C et D
        .Columns("C:D").EntireColumn.Hidden = True
 
    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
 
Private Sub Freq(R As Object, j As Long)
    Dim kR As Long, kC As Long
    Dim k(100) As Variant, n As Integer             '--- 100 = nombre maximal de colonnes dans la feuille
    Dim sGroupe As String, kRGroupe As Long
    kR = 30
    kRGroupe = kR
    sGroupe = ""
    With R
        .cells(kR, j).Value = "Fréquence" & vbLf & (j - 10) & " = 100%"
        .cells(kR, j).HorizontalAlignment = -4108
        kR = kR + 1
        While .cells(kR - 1, 2).Value <> ""
            If .cells(kR, 3).Value <> sGroupe Then  '--- nouveau groupe
                '--- résultat groupe précédent
                n = 0
                For kC = 8 To j - 3                 '--- 8 = première colonne de données
                    If k(kC) <> 0 Then n = n + 1    '--- nb de colonnes non nulles = nb de lieux
                    k(kC) = 0
                Next kC
                If sGroupe <> "" Then               '--- inscrit fréquence
                    .cells(kRGroupe, j).Value = n / (j - 10)
                    .cells(kRGroupe, j).numberFormat = "0%"
                    .cells(kRGroupe, j).HorizontalAlignment = -4108
                End If
                '--- début nouveau groupe
                kRGroupe = kR
                sGroupe = .cells(kR, 3).Value
            End If
            '--- cumul par colonne/lieu pour le groupe en cours
            For kC = 8 To j - 3                     '--- 8 = première colonne de données, j-3 dernière colonne
                k(kC) = k(kC) + .cells(kR, kC)
            Next kC
            kR = kR + 1
        Wend
    End With
End Sub

Cordialement.

**Salo15** · 22/10/2020, 08h22

Envoyé par EricDgn

Voilà, 2e essai!
et ligne 159 modifié pour que si Total = 0, inscrit un -.
Cordialement.

Bonjour,

Une fois de plus, un grand merci pour votre aide. Cela marche parfaitement.

Voici le tableau que j'arrive à obtenir. Je crois que c'est tout ...pour l'instant

**Salo15** · 22/10/2020, 18h48

Bonsoir Eric,

Je suis désolée de vous déranger à nouveau. J'ai dû rajouter une colonne à mon tableau, du coup mes échantillons s'affichent désormais à partir de la colonne I (auparavant c'était la colonne H). J'ai essayé de changer le code de la fréquence, en mettant "9" au lieu de "8" mais je crois qu'il y a une autre chose à modifier car dans le calcul, il me rajoute un échantillon de plus, je ne sais pas de quelle partie du code vient l'erreur...

Merci para 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
Private Sub Freq(R As Object, j As Long)
    Dim kR As Long, kC As Long
    Dim k(100) As Variant, n As Integer             '--- 100 = nombre maximal de colonnes dans la feuille
    Dim sGroupe As String, kRGroupe As Long
    kR = 30
    kRGroupe = kR
    sGroupe = ""
    With R
        .cells(kR, j).Value = "Fréquence" & vbLf & (j - 10) & " = 100%"
        kR = kR + 1
        While .cells(kR - 1, 2).Value <> ""
            If .cells(kR, 3).Value <> sGroupe Then  '--- nouveau groupe
                '--- résultat groupe précédent
                n = 0
                For kC = 9 To j - 3                 '--- 9 = première colonne de données
                    If k(kC) <> 0 Then n = n + 1    '--- nb de colonnes non nulles = nb de lieux
                    k(kC) = 0
                Next kC
                If sGroupe <> "" Then               '--- inscrit fréquence
                    .cells(kRGroupe, j).Value = n / (j - 10)
                    .cells(kRGroupe, j).numberFormat = "0%"
                    .cells(kRGroupe, j).Font.Bold = True
 
                End If
                '--- début nouveau groupe
                kRGroupe = kR
                sGroupe = .cells(kR, 3).Value
            End If
            '--- cumul par colonne/lieu pour le groupe en cours
            For kC = 9 To j - 3                     '--- 9 = première colonne de données, j-3 dernière colonne
                k(kC) = k(kC) + .cells(kR, kC)
            Next kC
            kR = kR + 1
        Wend
    End With

**EricDgn** · 22/10/2020, 19h58

Bonsoir,
Il me faudrait voir ce qu'il y a dans toutes les colonnes, y compris les colonnes masquées.
Cordialement.

**Salo15** · 22/10/2020, 20h17

Envoyé par EricDgn

Bonsoir,
Il me faudrait voir ce qu'il y a dans toutes les colonnes, y compris les colonnes masquées.
Cordialement.

Voici le tout dernier code (j'ai commencé à le modifier en mettant 9 au lieu de 8), et en image le tableau qui en sort.

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
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
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 xlWsTmp As Object
Dim i As Long
Dim j As Long
Dim Rng As Object
Dim sRng As String
Dim sFml As String
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
    With xlWs.cells
        .ClearContents
        .ClearFormats
        .Font.Name = "Arial"   '--- ou Arial Narrow ?
        .Font.Size = 10
        .HorizontalAlignment = -4108                        '--- xlCenter= -4108
        xlWs.Columns("A:H").HorizontalAlignment = -4131     '--- xlLeft= -4131
 
    End With
 
    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("H1").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
 
        '--- pour avoir 1 décimale ligne Densité
        j = .Range("I27").End(-4161).Column                     '--- n° dernière colonne non vide de la ligne n°27 --- xlToRight = -4161
        sRng = .Range(.cells(27, 9), .cells(27, j)).Address     '--- 9 = colonne I
        .Range(.cells(27, 9), .cells(27, j)).numberFormat = "0.0" '--- ou "0.0%" pour avoir 1 décimale
 
        '--- ajout totaux en dernière ligne                     '--- i = n° ligne vide en bas du tableau
        j = .Range("I30").End(-4161).Column                     '--- n° dernière colonne non vide de la ligne n°30 --- xlToRight = -4161
        sRng = .Range(.cells(31, 9), .cells(i - 1, 9)).Address  '--- 9 = colonne I
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        .Range(.cells(i, 9), .cells(i, j + 1)).Formula = "=SUM(" & sRng & ")"
        .cells(i, 2).Value = "Total NMI"
        .Range(.cells(i, 1), .cells(i, j + 2)).Font.Bold = True
        .Range(.cells(i, 1), .cells(i, j + 3)).Borders(8).Weight = 2   '--- xlEdgeTop = 8    --- xlThin = 2 --- xlMedium = -4138
        .Range(.cells(i, 1), .cells(i, j + 3)).Borders(9).Weight = 2   '--- xlEdgeBottom = 9
 
        '--- ajout totaux en dernière colonne
        j = j + 1                                               '--- n° colonne
        i = i - 1                                               '--- n° dernière ligne de données
        .cells(30, j).Value = "Total NMI"
        sRng = .Range(.cells(31, 9), .cells(31, j - 1)).Address '--- 31 = n° première ligne à sommer
        sRng = Replace(sRng, "$", "")                           '--- pour obtenir une adresse relative
        .Range(.cells(31, j), .cells(i, j)).Formula = "=SUM(" & sRng & ")"
        .Range(.cells(31, j), .cells(i, j)).Font.Bold = True
 
        '--- ajout pourcentages en dernière colonne
        j = j + 1                                               '--- n° colonne
        .cells(30, j).Value = .cells(i + 1, j - 1).Value & " = 100%"
        sRng = .cells(31, j - 1).Address
        sRng = Replace(sRng, "$", "")
        sRng = sRng & "/" & .cells(i + 1, j - 1).Address        '--- le rapport
        sFml = "=If(Rng=0,'-',If(Rng<0.005,'r', If(Rng<0.01,'+',Rng)))"  '--- modèle de la formule --- 0.005 = 5% --- 0.01 = 1%
        sFml = Replace(sFml, "Rng", sRng)                       '--- remplace Rng par sRng (rapport)
        sFml = Replace(sFml, "'", Chr(34))                      '--- remplace les " par "
        .Range(.cells(31, j), .cells(i, j)).Formula = sFml
        .Range(.cells(31, j), .cells(i, j)).numberFormat = "0%" '--- ou "0.0%" pour avoir 1 décimale
        .Range(.cells(31, j), .cells(i, j)).Font.Bold = True
 
        '--- ajouts fréquences
        Freq xlWs, j + 1
 
 
        '--- ajouts des sous-titres
        sTitre = ""
        i = 31
        Do While .Range("A" & i).Value <> ""            '--- parcourt la liste jusqu'à tomber sur celule vide
            If .Range("E" & i).Value <> sTitre Then
                sTitre = .Range("E" & 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
                .Range(.cells(i, 2), .cells(i, j)).Merge                        '--- j = n° colonne pourcentages
            End If
            i = i + 1
        Loop
 
        '--- masquer colonnes C, D et E
        .Columns("C:E").EntireColumn.Hidden = True
 
    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
 
Private Sub Freq(R As Object, j As Long)
    Dim kR As Long, kC As Long
    Dim k(100) As Variant, n As Integer             '--- 100 = nombre maximal de colonnes dans la feuille
    Dim sGroupe As String, kRGroupe As Long
    kR = 30
    kRGroupe = kR
    sGroupe = ""
    With R
        .cells(kR, j).Value = "Fréquence" & vbLf & (j - 10) & " = 100%"
        kR = kR + 1
        While .cells(kR - 1, 3).Value <> ""
            If .cells(kR, 3).Value <> sGroupe Then  '--- nouveau groupe
                '--- résultat groupe précédent
                n = 0
                For kC = 9 To j - 3                 '--- 9 = première colonne de données
                    If k(kC) <> 0 Then n = n + 1    '--- nb de colonnes non nulles = nb de lieux
                    k(kC) = 0
                Next kC
                If sGroupe <> "" Then               '--- inscrit fréquence
                    .cells(kRGroupe, j).Value = n / (j - 10)
                    .cells(kRGroupe, j).numberFormat = "0%"
                    .cells(kRGroupe, j).Font.Bold = True
 
                End If
                '--- début nouveau groupe
                kRGroupe = kR
                sGroupe = .cells(kR, 3).Value
            End If
            '--- cumul par colonne/lieu pour le groupe en cours
            For kC = 9 To j - 3                     '--- 9 = première colonne de données, j-3 dernière colonne
                k(kC) = k(kC) + .cells(kR, kC)
            Next kC
            kR = kR + 1
        Wend
    End With
End Sub

Merci par avance

**EricDgn** · 22/10/2020, 20h59

Bonsoir,
Ligne 214 et 225, remplacer j-10 par j-11.
Cordialement.

**Salo15** · 22/10/2020, 21h43

Envoyé par EricDgn

Bonsoir,
Ligne 214 et 225, remplacer j-10 par j-11.
Cordialement.

Super, ça marche, merci beaucoup.

J'avais une autre demande mais je crains que ce soit trop compliqué à mettre en place :
- Serait-il possible de reprendre ces "regroupements" de taxons et, en fonction de la fréquence, les trier de plus grand au plus petit ? Dans la première image ce que j'obtiens actuellement, dans la deuxième image en rouge ce que je souhaiterais obtenir.
Sachant que les regroupements "A. WTriticum sp." et "A. ZCerealia indeterminata" (colonne C) de la catégorie "A. Céréales" (colonne E) et "B. ZLeguminosae sativae indeterminatae" (colonne C) de la catégorie "B. Légumineuses" (colonne E) doivent rester toujours en bas de leur groupe respectif...

Merci par avance

**EricDgn** · 23/10/2020, 11h07

Bonjour,
Etait-ce pour cela que vous avez ajouté la colonne D: ordre de présentation ? C'est pour savoir si cette colonne est utilisable. Il serait utile de déposer un fichier xlsx avec les données des lignes 30 à 53 de votre exemple.
Cordialement.

Transposer une table Access vers Excel avec VBA

Requêtes et SQL.

Discussions similaires

Partager

Partager