Discussion :

[Salo15]

Bonjour à tous,

Voici ma problématique : en cliquant sur un bouton dans un formulaire, je cherche à exporter mes données vers un fichier excel qui contient deux feuilles.
- étape 1 : La feuille "PresentationEchant" contient les données issues de la requête "RQT_Decompte_PresentationEchant".
- étape 2 : La feuille "Decompte" doit contenir les données issues de deux requêtes "RQT_Decompte_AC_EchantColonne_TaxonLigne" (les données doivent apparaître à partir de la cellule A28 de la feuille Excel) et "RQT_Decompte_InfosEchant" (les données doivent apparaître à partir de la cellule F1 de la feuille Excel).
- étape 3 : J'ai besoin que les données issues de la requête "RQT_Decompte_InfosEchant" (qui apparaissent à partir de la cellule F1) soient transposées.

Jusque l'étape 2 cela marche très bien avec le code VBA que vous trouverez ci-dessous (j'ai réussi à le construire grâce à d'autres discussions sur ce forum). Mais je n'arrive pas à résoudre l'étape 3 et donc à transposer les données.

Vu que l'informatique n'est pas du tout mon domaine, je compte sur vous pour pouvoir trouver la solution à la gestion des mes données de thèse (j'ai presque une centaine de tableaux à gérer et la fonction manuelle collage spécial-transposer sur Excel ne me convient pas vraiment.

Merci par avance

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
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
 
    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Open("C:\Users\Laura\Desktop\Thèse\BDD\BDRAB thèse\Tableurs_Decompte\Export.xlsx")
' rendre visible Excel
    xlApp.Visible = True
 
    Set oDb = CurrentDb()
' Export table1
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_PresentationEchant")
' définition feuille 1
    Set xlWs = xlWb.Worksheets("PresentationEchant")
 
' suppression des anciennes données table 1
    xlWs.Activate
 
    xlWs.Cells.Select
    xlApp.Selection.Delete
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A1").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 1
    If Not oRst.EOF Then xlWs.Cells(2, 1).CopyFromRecordset oRst
    xlWs.Range("A1").Select
 
' Export table2
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_InfosEchant")
' définition feuille 2
    Set xlWs = xlWb.Worksheets("Decompte")
 
' suppression des anciennes données table 2
    xlWs.Activate
    xlWs.Cells.Select
    xlApp.Selection.Delete
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("F1").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 2
    If Not oRst.EOF Then xlWs.Range("F2").CopyFromRecordset oRst
    xlWs.Range("F1").Select
 
    ' Export table3
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_AC_EchantColonne_TaxonLigne")
' définition feuille 3
    Set xlWs = xlWb.Worksheets("Decompte")
 
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A28").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 3
    If Not oRst.EOF Then xlWs.Range("A29").CopyFromRecordset oRst
    xlWs.Range("A28").Select
 
' fermeture des instances ouvertes
    oRst.Close
    xlWb.Close True
    Set oRst = Nothing
    Set oDb = Nothing
    Set xlWs = Nothing
    Set xlWb = Nothing
    Set xlApp = Nothing
 
End Sub

[EricDgn]

Bonjour,

La façon la plus simple me semble être
- de commencer par copier les données dans une plage non utilisée de la feuille (p.ex K1)
- puis d'effectuer un collage spécial de la plage créée à cet endroit pour la transposer à l'endroit voulu (A28),
- enfin supprimer la plage initiale.

Ce qui donne pour les lignes 55 à 68 de votre 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
...
Dim Rng as Object
...
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_AC_EchantColonne_TaxonLigne")
    Set xlWs = xlWb.Worksheets("Decompte")              ' définition feuille 3
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("K1").Offset(0, i) = oRst(i).Name    ' entête dans 1ère ligne --- plage temporaire
    Next i
    If Not oRst.EOF Then
        xlWs.Range("K2").CopyFromRecordset oRst         ' enregistrement temporaire nouvelles données table 3
        Set Rng = xlWs.usedrange                        ' récupérer données
        Rng.copy
        xlWs.[A28].pastespecial transpose:=True         ' transposer à l'endroit souhaité
        Rng.Clear                                       ' vider plage temporaire
    End If
    xlWs.Range("A28").Select

Cordialement.

[Salo15]

Bonjour Eric,

Cela marche parfaitement ! Merci beaucoup pour votre aide !

Juste une dernière question : à votre avis, serait-il possible qu'au lieu de supprimer les anciennes données des cellules à chaque export, je puisse demander avec le code juste d'en effacer le contenu ? L'idée est de pouvoir faire de manière à ce que la mise en page de mon tableur Excel soit conservée à chaque export (largeur des colonnes, gras, etc.).
J'ai essayé avec ".ClearContents" au lieu de ".Delete" mais cela ne marche pas, cela m'affiche un message d'erreur d'exécution 1004 : Cette sélection n'est pas valide. Vérifiez que les zones de copie et de collage ne se chevauchent pas, sauf si elles ont la même taille et la même forme.

Merci par avance,
Cordialement

[tee_grandbois]

bonsoir,

J'ai essayé avec ".ClearContents"

fais-tu bien la sélection des cellules à vider avant ?

[EricDgn]

Bonsoir,
Effectivement, normalement xlWs.Cells.ClearContents (à la place des lignes 24-25, 42-44) devrait faire cela.
De même: xlWs.[A28].PasteSpecial Paste:=xlPasteValues, Transpose:=True.
Cordialement.

[Salo15]

Bonsoir,
Effectivement, normalement xlWs.Cells.ClearContents (à la place des lignes 24-25, 42-44) devrait faire cela.
De même: xlWs.[A28].PasteSpecial Paste:=xlPasteValues, Transpose:=True.
Cordialement.

Bonjour Eric,
Merci pour votre réponse.
Alors, pour ce qui est de la première feuille de mon fichier exporté, xlWs.Cells.ClearContents (à la place de la ligne 25) marche très bien.
Par contre, dès que je remplace xlApp.Selection.Delete par xlWs.Cells.ClearContents (ligne 44), dans la feuille 2 cela ne marche pas. Par ailleurs, si je rajoute xlWs.[F1].PasteSpecial Paste:=xlPasteValues, Transpose:=True (ligne 58) cela m'affiche un message d'erreur de syntaxe.

Voici le code qui marche bien pour l'instant (pour information, le collage transposé je l'ai fait à partir de "F1" et non pas de"A28").
Merci par avance,

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
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
 
    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Open("C:\Users\Laura\Desktop\Thèse\BDD\BDRAB thèse\Tableurs_Decompte\Export.xlsx")
' rendre visible Excel
    xlApp.Visible = True
 
    Set oDb = CurrentDb()
' Export table1
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_PresentationEchant")
' définition feuille 1
    Set xlWs = xlWb.Worksheets("PresentationEchant")
 
' suppression des anciennes données table 1
    xlWs.Activate
    xlWs.Cells.Select
    xlWs.Cells.ClearContents
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A1").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 1
    If Not oRst.EOF Then xlWs.Cells(2, 1).CopyFromRecordset oRst
    xlWs.Range("A1").Select
 
' Export table2
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_InfosEchant")
' définition feuille 2
    Set xlWs = xlWb.Worksheets("Decompte")
 
' suppression des anciennes données table 2
    xlWs.Activate
    xlWs.Cells.Select
    xlApp.Selection.Delete
 
' entête dans 1ère ligne --- plage temporaire
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A200").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement temporaire des nouvelles données table 2
    If Not oRst.EOF Then xlWs.Range("A201").CopyFromRecordset oRst
 
 ' récupérer données
 Set Rng = xlWs.usedrange
 
 ' transposer à l'endroit souhaité
 Rng.copy
 xlWs.[F1].pastespecial transpose:=True
 
 ' vider plage temporaire
 Rng.Clear
xlWs.Range("F1").Select
 
' Export table3
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_AC_EchantColonne_TaxonLigne")
' définition feuille 2
    Set xlWs = xlWb.Worksheets("Decompte")
 
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A28").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 3
    If Not oRst.EOF Then xlWs.Range("A29").CopyFromRecordset oRst
    xlWs.Range("A28").Select
 
' fermeture des instances ouvertes
    oRst.Close
    xlWb.Close True
    Set oRst = Nothing
    Set oDb = Nothing
    Set xlWs = Nothing
    Set xlWb = Nothing
    Set xlApp = Nothing
 
End Sub

[Salo15]

bonsoir,

fais-tu bien la sélection des cellules à vider avant ?

Bonjour,

Etant donné que mes tableurs varient en nombre de colonnes et de lignes d'un export à l'autre, l'idéal est de pouvoir effacer le contenu de toutes les cellules et donc de ne pas limiter la sélection des cellules à vider...

[EricDgn]

Bonjour,

Je ne vois pas très bien d'où vient l'erreur. Peut-être remplacer .[F1] par .Range("F1")

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
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, Rng As Object    '--- Rng 
Dim i As Long
 
    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Open("C:\Users\Laura\Desktop\Thèse\BDD\BDRAB thèse\Tableurs_Decompte\Export.xlsx")
' rendre visible Excel
    xlApp.Visible = True
 
    Set oDb = CurrentDb()
' Export table1
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_PresentationEchant")
' définition feuille 1
    Set xlWs = xlWb.Worksheets("PresentationEchant")
 
' efface les anciennes données table 1
    xlWs.Select
    xlWs.Cells.ClearContents
 
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A1").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 1
    If Not oRst.EOF Then xlWs.Cells(2, 1).CopyFromRecordset oRst
    xlWs.Range("A1").Select
 
' Export table2
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_InfosEchant")
' définition feuille 2
    Set xlWs = xlWb.Worksheets("Decompte")
 
' efface les anciennes données table 2
    xlWs.Select
    xlWs.Cells.ClearContents
 
 
' entête dans 1ère ligne --- plage temporaire
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A200").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement temporaire des nouvelles données table 2
    If Not oRst.EOF Then xlWs.Range("A201").CopyFromRecordset oRst
 
 ' récupérer données
    Set Rng = xlWs.UsedRange
 
 ' transposer à l'endroit souhaité
    Rng.Copy
    xlWs.Range("F1").PasteSpecial Paste:=xlPasteValues, Transpose:=True
 
 ' vider plage temporaire
    Rng.Clear
    xlWs.Range("F1").Select   '--- inutile, sauf si c'est pour voir au moment du débogage
 
' Export table3
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_AC_EchantColonne_TaxonLigne")
' définition feuille 2
    Set xlWs = xlWb.Worksheets("Decompte")      '--- ? inutile, déjà fait
 
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A28").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 3
    If Not oRst.EOF Then xlWs.Range("A29").CopyFromRecordset oRst
    xlWs.Range("A28").Select
 
' fermeture des instances ouvertes
    oRst.Close
    xlWb.Close True
    Set oRst = Nothing
    Set oDb = Nothing
    Set Rng = Nothing
    Set xlWs = Nothing
    Set xlWb = Nothing
    Set xlApp = Nothing
 
End Sub

Cordialement.

[tee_grandbois]

bonjour,

Bonjour,

Etant donné que mes tableurs varient en nombre de colonnes et de lignes d'un export à l'autre, l'idéal est de pouvoir effacer le contenu de toutes les cellules et donc de ne pas limiter la sélection des cellules à vider...

oui, j'ai vu après coup que la commande existait: xlWs.Select

[Salo15]

Bonjour,

Je ne vois pas très bien d'où vient l'erreur. Peut-être remplacer .[F1] par .Range("F1")

Cordialement.

Re-bonjour Eric,

Je vous remercie pour le temps que vous consacrez à me répondre. J'ai perfectionné mon code grâce à vos observations, j'ai fait plusieurs tests mais cela ne marche toujours pas. Toujours le même message d'erreur de syntaxe au moment de coller les valeurs et le message comme quoi les cellules se chevauchent. Tant pis ! Je vais laisser tomber, j'aurais souhaité trouver une solution pour éviter de refaire une mise en page manuelle à chaque export mais le plus gros du problème est résolu.

Maintenant, si cela ne vous dérange pas, il y un autre aspect de mon export que je souhaiterais affiner. Toujours dans cette feuille 2 de mon fichier, à partir de la ligne 29 chaque ligne correspond à un taxon de plantes différent. Dans la colonne F à partir de la cellule F29 s'affichent les catégories de mes taxons. J'ai par exemple les taxons compris entre les lignes 29 et 39 qui appartiennent à la catégorie "A. Céréales", ensuite se trouvent les taxons qui appartiennent à la catégorie "B. Légumineuses". J'ai au total 21 catégories. Je souhaiterais qu'à chaque fois que cette catégorie de taxons change, il y ait une ligne qui s'insère avec le nom de la catégorie dans la colonne B (vous trouverez dans la première image ce que j'obtiens actuellement et dans la deuxième image ce que je souhaite obtenir en rouge).

J'ai trouvé dans un forum ce code que j'ai essayé d'adapter à mon code mais cela ne marche pas. Je ne connais rien au langage VBA.
Auriez-vous une idée ?
Merci encore !

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
' Export table3
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_AC_EchantColonne_TaxonLigne")
 
' définition feuille 2
    Set xlWs = xlWb.Worksheets("Decompte")
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A28").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 3
    If Not oRst.EOF Then xlWs.Range("A29").CopyFromRecordset oRst
    xlWs.Range("A28").Select
 
'Pour chaque ligne de la feuille à partir de la ligne 29
            For i = xlWs.Range("A29").End(xlUp).Row To 29 Step -1
'Si la colonne F change de données (changement de catégorie de taxon)
            If xlWs.Range("F" & i).Value <> "A. Céréales" Then
'On selection la ligne de dessous et on insert un ligne au dessus
            xlWs.Rows(i + 1).Select
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
 
'Si la colonne F change de données (changement de catégorie de taxon)
            If xlWs.Range("F" & i).Value <> "B. Légumineuses" Then
'On selection la ligne de dessous et on insert un ligne au dessus
            xlWs.Rows(i + 1).Select
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove        
 
' fermeture des instances ouvertes
    oRst.Close
    xlWb.Close True
    Set oRst = Nothing
    Set oDb = Nothing
    Set xlWs = Nothing
    Set xlWb = Nothing
    Set xlApp = Nothing
 
 End If
Next i
End Sub

[EricDgn]

Bonjour,

...les cellules se chevauchent.

C'est que la plage est plus grande que vous le pensez et que la plage copiée recouvre en partie la plage sur laquelle elle va tomber après transposition. Pour éviter cela, le plus simple est que vous ajoutiez dans votre dossier Excel une feuille nommée Tmp (pour "temporaire") et d'y déposer temporairement les données de la table 3, copiées-collées avec transposition ensuite dans la feuille "Decompte".

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
Option Explicit
 
Private Sub Exporter_RQT_Click()
 
Dim oRst As Recordset
Dim oDb As Database
Dim xlApp As Object
Dim xlWb As Object
Dim xlWs As Object
Dim i As Long
Dim Rng As Object       '<---
Dim xlWsTmp As Object   '<---
 
    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Open("C:\Users\Laura\Desktop\Thèse\BDD\BDRAB thèse\Tableurs_Decompte\Export.xlsx")
' rendre visible Excel
    xlApp.Visible = True
 
    Set oDb = CurrentDb()
 
'--- Export table1
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_PresentationEchant")
' définition feuille 1
    Set xlWs = xlWb.Worksheets("PresentationEchant")
 
' efface les anciennes données table 1
    xlWs.Select
    xlWs.Cells.ClearContents
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A1").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 1
    If Not oRst.EOF Then xlWs.Cells(2, 1).CopyFromRecordset oRst
    xlWs.Range("A1").Select
 
'--- Export table2
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_InfosEchant")
' définition feuille 2
    Set xlWs = xlWb.Worksheets("Decompte")
 
' efface les anciennes données table 2
    xlWs.Select
    xlWs.Cells.ClearContents
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("F1").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 2
    If Not oRst.EOF Then xlWs.Range("F2").CopyFromRecordset oRst
    xlWs.Range("F1").Select
 
'--- Export table3
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_AC_EchantColonne_TaxonLigne")
 
' 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("A28").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 3
    If Not oRst.EOF Then xlWs.Range("A1").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:=xlPasteValues, Transpose:=True
 
' vide plage temporaire
    Rng.Clear
    xlWs.Select
 
' fermeture des instances ouvertes
    oRst.Close
    xlWb.Close True
    Set oRst = Nothing
    Set oDb = Nothing
    Set Rng = Nothing
    Set xlWsTmp = Nothing
    Set xlWs = Nothing
    Set xlWb = Nothing
    Set xlApp = Nothing
 
End Sub

Dites-moi si cela fonctionne.
Cordialement.

[EricDgn]

Pour ce qui est d'insérer des titres:

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
    Dim sTitre As String
    'Pour chaque ligne de la feuille à partir de la ligne 29
    xlWs.Select
    sTitre = ""
    i = 29
    Do While Range("A" & i).Value <> ""
        If Range("F" & i).Value <> sTitre Then
            sTitre = Range("F" & i).Value
            Range("A" & i).EntireRow.Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Range("B" & i).Value = sTitre
        End If
        i = i + 1
    Loop

Cordialement.

[Salo15]

Pour ce qui est d'insérer des titres:

Bonjour,

J'ai inséré le code mais ça ne marche pas, regardez ce qui s'affiche :
N.B. j'ai bien mis Dim sTitre As String en début de mon code

[EricDgn]

Bonjour,
Pour cette partie là, remplacer les Range par xlWs.Range
ou encore, pour être plus propre:

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
    xlWs.Select
    sTitre = ""
    i = 29
    With xlWs
        Do While .Range("A" & i).Value <> ""
            If .Range("F" & i).Value <> sTitre Then
                sTitre = .Range("F" & i).Value
                .Range("A" & i).EntireRow.Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                .Range("B" & i).Value = sTitre
            End If
            i = i + 1
        Loop
    End With

Cordialement.

[Salo15]

Cela marche nickel ! Merci beaucoup !
Pour l'autre question je vous fais une réponse à part car ça ne marche pas tout à fait...

[Salo15]

Bonjour,

C'est que la plage est plus grande que vous le pensez et que la plage copiée recouvre en partie la plage sur laquelle elle va tomber après transposition. Pour éviter cela, le plus simple est que vous ajoutiez dans votre dossier Excel une feuille nommée Tmp (pour "temporaire") et d'y déposer temporairement les données de la table 3, copiées-collées avec transposition ensuite dans la feuille "Decompte".

Dites-moi si cela fonctionne.
Cordialement.

Re-bonjour Eric,

Une fois de plus je tiens à vous remercier pour le temps que vous consacrez à répondre à mes questions, mon tableur Excel tel que je le souhaite commence à prendre forme.

Alors pour cette question, d'un côté j'ai toujours le même problème avec Paste:=xlPasteValues, il m'affiche "erreur de compilation : variable non définie". De l'autre côté, mes données collées avec transposition présentent un problème : il y ajuste l'en-tête qui se transpose à partir de la cellule F1, mais les autres données ne sont pas transposées et sont collées à partir de la cellule A1 (voir l'image).

Voici le code :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
Option Explicit
 
Private Sub Exporter_RQT_Click()
 
Dim oRst As Recordset
Dim oDb As Database
Dim xlApp As Object
Dim xlWb As Object
Dim xlWs As Object
Dim i As Long
Dim Rng As Object       '<---
Dim xlWsTmp As Object   '<---
 
    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Open("C:\Users\Laura\Desktop\Thèse\BDD\BDRAB thèse\Tableurs_Decompte\Export.xlsx")
' rendre visible Excel
    xlApp.Visible = True
 
    Set oDb = CurrentDb()
 
'--- Export table1
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_PresentationEchant")
' définition feuille 1
    Set xlWs = xlWb.Worksheets("PresentationEchant")
 
' efface les anciennes données table 1
    xlWs.Select
    xlWs.Cells.ClearContents
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A1").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 1
    If Not oRst.EOF Then xlWs.Cells(2, 1).CopyFromRecordset oRst
    xlWs.Range("A1").Select
 
'--- Export table2
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_AC_EchantColonne_TaxonLigne")
 
' définition feuille 2
    Set xlWs = xlWb.Worksheets("Decompte")
 
' efface les anciennes données table 2
    xlWs.Select
    xlWs.Cells.ClearContents
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWs.Range("A28").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 2
    If Not oRst.EOF Then xlWs.Range("A29").CopyFromRecordset oRst
    xlWs.Range("A28").Select
 
'--- Export table3
    Set oRst = oDb.OpenRecordset("select * from RQT_Decompte_InfosEchant")
 
' définition feuille Tmp (reçoit données à transposer)
    Set xlWsTmp = xlWb.Worksheets("Tmp")   '<--- avoir aussi une feuille nommée Tmp
    xlWsTmp.Select
 
' entête dans 1ère ligne
    For i = 0 To oRst.Fields.Count - 1
        xlWsTmp.Range("A1").Offset(0, i) = oRst(i).Name
    Next i
 
' enregistrement des nouvelles données table 3
    If Not oRst.EOF Then xlWs.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 Transpose:=True
 
' vide plage temporaire
    Rng.Clear
    xlWs.Select
 
' fermeture des instances ouvertes
    oRst.Close
    xlWb.Close True
    Set oRst = Nothing
    Set oDb = Nothing
    Set Rng = Nothing
    Set xlWsTmp = Nothing
    Set xlWs = Nothing
    Set xlWb = Nothing
    Set xlApp = Nothing
 
End Sub

[EricDgn]

Effectivement, il y une erreur (de destination) à la ligne 71 qui doit s'écrire:

Code :

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

    If Not oRst.EOF Then xlWsTmp.Range("A2").CopyFromRecordset oRst

et pour la ligne PasteSpecial, il faut indiquer:

Code :

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

    xlWs.Range("F1").PasteSpecial Paste:=-4163, Transpose:=True

-4163 étant la valeur de la constante xlPasteValues (valeur que l'on peut trouver dans l'Aide de Excel).

Cordialement.

[Salo15]

Re-bonjour,

C'est parfait, ça marche nickel. Juste pour information, j'ai eu le problème affiché en image, alors je me suis dit que c'était aussi un problème à traiter avec la valeur de la constante, du coup j'ai modifié le code (voir la modification) et cela a marché.

encore merci !

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
'Pour chaque ligne de la feuille à partir de la ligne 29
    xlWs.Select
    sTitre = ""
    i = 29
    With xlWs
        Do While .Range("A" & i).Value <> ""
            If .Range("F" & i).Value <> sTitre Then
                sTitre = .Range("F" & i).Value
                .Range("A" & i).EntireRow.Insert shift:=-4121, CopyOrigin:=0
                .Range("B" & i).Value = sTitre
                .Range("B" & i).Font.Bold = True
            End If
            i = i + 1
        Loop
    End With

[Salo15]

Bonsoir Eric,

Il y une dernière chose que je voudrais mettre en place pour rendre mon fichier Excel opérationnel. A partir de la cellule B30, j'ai les noms des taxons en latin (voir l'image). Or, normalement ils doivent s'afficher en italique sauf pour certains mots comme "cf." ou "sp.", entre autres. J'avais crée un code VBA sur excel qui marche très bien et qui me permet d'avoir le résultat souhaité, mais cela m'oblige à passer par ce module à chaque fois.
Du coup, je voudrais savoir de quelle façon je peux intégrer ce code au code sur lequel on travail actuellement, de manière à obtenir le résultat en même temps que j'exporte mon fichier. J'i essayé de l'adapter mais ça ne marche pas.

Merci par avance !

voici le code VBA excel

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

[EricDgn]

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