Discussion :

[PAULOM]

Bonjour à tous,

J'ai un petit problème concernant l'exportation d'une table ACCESS vers EXCEL.
Je veux exporter la table "T31_Cumul_Nvx_clients_par_BG" dans la feuille "S0" du fichier EXCEL "Nvx clients par BG 2006 S14.xls".
Dans la table ACCESS il ya le champ le champ "semaine" composé de 2 chiffres, ces 2 chiffres je veux les recupérer pour copier la feuille "S0" pour en faire une "Sxx", je veux également mettre les différents champs dans les feuilles EXCEL.
Puis enfin je veux mettre dans la feuille "Semaine S-1" les données de la feuille "Sxx -1" celle de la semaine précédente.

Pour l'instant j'ai un petit problème avec une fois sur deux cette erreur "462-Le serveur distant n'existe pas ou n'est pas disponible"
Voici pour l'instant mon 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
Option Compare Database
 
Global Const RepertoireTableauBord As String = "C:\Documents and Settings\A4382\Bureau\stage\"
Global Const Titre As String = "Suivi Conquête "
Dim erreur_traitement As Boolean
Sub ExportTblAccessInExcel()
 
Dim Db As DAO.Database
Dim Rs As DAO.Recordset
Dim Xlapp As Excel.Application
Dim XlBook As Excel.Workbook
Dim XlSheet As Excel.Worksheet
 
On Error GoTo errOuvrirExcel
Set Xlapp = GetObject(, "Excel.Application")
On Error GoTo oups:
Xlapp.Visible = True
 
Set XlBook = Xlapp.Workbooks.Open("C:\Documents and Settings\A4382\Bureau\stage\Nvx clients par BG 2006 S14.xls")
Set XlSheet = XlBook.Worksheets("S0")
Set appexcel = New Excel.Application
Numsemaine = "S0"
' efface les données
XlSheet.Cells.Clear
Set Db = CurrentDb
' Copie dans S0
Set Rs = Db.OpenRecordset("T31_Cumul_Nvx_clients_par_BG", , dbOpenForwardOnly)
XlSheet.Range("A1").CopyFromRecordset Rs
Set XlSheet = Nothing
' Ajout de la feuille
Sheets("S0").Select
Sheets("S0").Copy Before:=Sheets(18)
Sheets("S15").Select
ActiveWindow.SelectedSheets.Delete
Sheets("S0 (2)").Select
Sheets("S0 (2)").Name = "S15"
Sheets("_S15").Select
ActiveWindow.SelectedSheets.Delete
' remise au début car le 'CopyFromRecordset' ne le fait pas
Rs.MoveFirst
XlSheet.Range("A1").CopyFromRecordset Rs
 
' Ferme les Var
Rs.Close: Set Rs = Nothing
Db.Close: Set Db = Nothing
Set XlSheet = Nothing
' Sauve le fichier
XlBook.Save
XlBook.Close
Set XlBook = Nothing
Set Xlapp = Nothing
 
Exit Sub
errOuvrirExcel:
'Err 429 : Un serveur OLE Automation ne peut pas créer d'objet
' -> Excel n'est PAS encore ouvert.
If Err = 429 Then
Set Xlapp = CreateObject("Excel.Application")
Resume Next
End If
oups:
MsgBox Err.Number & " - " & Err.Description
End Sub

Merci à vous pour votre aide

[Modération, cafeine : Pensez à utiliser la balise [code] qui améliore la lisibilité, merci]

[PAULOM]

Merci cafeine j'ai du mal à trouver la balise [CODE]....

Décidement j'ai du mal à resoudre ce problème si quelqu'un peut m'aider...

Merci à vous

[LedZeppII]

Bonjour,

Au premier coup d'oeil, il y a juste une chose qui m'interpelle, c'est

Code :

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

1
2
 
Set appexcel = New Excel.Application

appexcel n'est pas utilisé dans ton code, et surtout il n'y a pas de appexcel.Quit
Tu risques d'avoir plusieurs EXCEL.EXE dans la liste des taches.
Essaie en retirant cette ligne pour voir.

Bon courage.

[PAULOM]

Bonjour,

Au premier coup d'oeil, il y a juste une chose qui m'interpelle, c'est

Code :

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

1
2
 
Set appexcel = New Excel.Application

appexcel n'est pas utilisé dans ton code, et surtout il n'y a pas de appexcel.Quit
Tu risques d'avoir plusieurs EXCEL.EXE dans la liste des taches.
Essaie en retirant cette ligne pour voir.

Bon courage.

Meric pour ton aide, mais en elevant la ligne que tu ma demandé d'enlever ça change pratiquement rien car j'ai toujours les EXCEL.EXE dans le "gestionnaire des tâches" et j'ai maintenant une nouvelle erreur:
9-l'indice n'appartient pas à la selection

Que dois-je faire?

Merci d'avance

[LedZeppII]

Je ne penses pas que l'erreur soit en rapport avec la ligne supprimée.
A mon avis tu fais référence à une feuille Excel qui n'existe pas (ou plus)

Code :

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

1
2
3
4
5
6
 
Sheets(18)
ou
Sheets("S15")
ou
Sheets("_S15")

Pour la mise au point du code remplaces temporairement

Code :

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

1
2
 
On Error GoTo oups:

par

Code :

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

1
2
3
 
' On Error GoTo oups:
On Error GoTo 0

Ainsi tu verras quel est la ligne en cause.

Bon courage

[PAULOM]

Je ne penses pas que l'erreur soit en rapport avec la ligne supprimée.
A mon avis tu fais référence à une feuille Excel qui n'existe pas (ou plus)

Code :

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

1
2
3
4
5
6
 
Sheets(18)
ou
Sheets("S15")
ou
Sheets("_S15")

Pour la mise au point du code remplaces temporairement

Code :

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

1
2
 
On Error GoTo oups:

par

Code :

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

1
2
3
 
' On Error GoTo oups:
On Error GoTo 0

Ainsi tu verras quel est la ligne en cause.

Bon courage

En effet Led, t'a petite astuce marche bien et me dit direct la ligne ou ça cloche, donc j'ai changé quelque petit trucs comme le coup "S_15" qui n'était plus trop d'actualité.
Mais 2 erreurs persistent que le debogueur me trouve:

Code :

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

Sheets("S0").Select

et

Code :

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

1
2
Rs.MoveFirst
XlSheet.Range("A1").CopyFromRecordset Rs

Donc je suis encore bloqué

[LedZeppII]

Pour

Sheets("S0").Select

Je serai tenté de dire que la feuille n'existe pas.

Pour

Rs.MoveFirst
XlSheet.Range("A1").CopyFromRecordset Rs

c'est parce que plus haut il y a

Code :

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

Set XlSheet = Nothing

Sinon on peut simplifier le code comme ci-après, pour avoir moins de références à des noms de feuilles.
J'ai mis en rouge des valeurs que j'ai remplacé par les miennes pour tester 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
 Sub ExportTblAccessInExcel()

Dim Db As DAO.Database
Dim Rs As DAO.Recordset
Dim Xlapp As Excel.Application
Dim XlBook As Excel.Workbook
Dim XlSheet As Excel.Worksheet
Dim NomFeuille As String

On Error GoTo errOuvrirExcel
Set Xlapp = GetObject(, "Excel.Application")
 'On Error GoTo oups:
On Error GoTo 0
Xlapp.Visible = True

NomFeuille = "S" & DatePart("ww", Date)

Set XlBook = Xlapp.Workbooks.Open(RepertoireTableauBord)
If FeuilleExiste(NomFeuille, XlBook) Then
   Set XlSheet = XlBook.Worksheets(NomFeuille)
   ' efface les données
   XlSheet.Cells.Clear
Else
   ' Ajouter nouvelle feuille en dernière position
   Set XlSheet = XlBook.Worksheets.Add(, XlBook.Worksheets(XlBook.Worksheets.Count))
   XlSheet.Name = NomFeuille
End If

Set Db = CurrentDb
 ' Copie dans feuille (nouvelle ou effacée)
Set Rs = Db.OpenRecordset("Pdts", , dbOpenForwardOnly)
XlSheet.Range("A1").CopyFromRecordset Rs
Set XlSheet = Nothing

 ' Ferme les Var
Rs.Close: Set Rs = Nothing
Db.Close: Set Db = Nothing
Set XlSheet = Nothing
 ' Sauve le fichier
XlBook.Save
XlBook.Close
Set XlBook = Nothing
Set Xlapp = Nothing

Exit Sub
errOuvrirExcel:
'Err 429 : Un serveur OLE Automation ne peut pas créer d'objet
' -> Excel n'est PAS encore ouvert.
If Err = 429 Then
Set Xlapp = CreateObject("Excel.Application")
Resume Next
End If
oups:
MsgBox Err.Number & " - " & Err.Description
 End Sub

 Function FeuilleExiste(NomFeuille As String, Classeur As Excel.Workbook) As Boolean
Dim errNum As Long, strName As String
  errNum = 0: Err.Clear
   On Error Resume Next
   strName = Classeur.Worksheets(NomFeuille).Name
   errNum = Err.Number
   On Error GoTo 0
   If errNum = 0 Then FeuilleExiste = True Else FeuilleExiste = False
End Function

Bonne continuation.

[PAULOM]

Merci beaucoup ce que tu fait Led Zepp et je te donne la réponse demain....

Encore merci pour ton travail.


Cordialement,

[PAULOM]

Ton code marche parfaitement ledzepp, mais j'ai quelque souci avec cette partie là:

Code :

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

1
2
3
4
' Copie dans feuille (nouvelle ou effacée)
Set Rs = Db.OpenRecordset("T31_Cumul_Nvx_clients_par_BG", , dbOpenForwardOnly)
XlSheet.Range("A1").CopyFromRecordset Rs
Set XlSheet = Nothing

Donc j'ai remplacé ta table "pdts" par ma table "T31_Cumul_Nvx_clients_par_BG" , mais le problème quand je lance le programme il ne s'affiche rien sur Excel (page grise).

Donc j'ai rajouté cette partie:

Code :

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

1
2
3
4
5
6
7
' Copie dans feuille (nouvelle ou effacée)
Set Rs = Db.OpenRecordset("T31_Cumul_Nvx_clients_par_BG", , dbOpenForwardOnly)
XlSheet.Range("A1").CopyFromRecordset Rs
Set XlSheet = Nothing
' remise au début car le 'CopyFromRecordset' ne le fait pas
Rs.MoveFirst
XlSheet.Range("A1").CopyFromRecordset Rs

Il me met cette erreur:
Erreur 91- Varaible objet ou variable de bloc with non définie

Merci pour ton aide LedZeppII

[LedZeppII]

Bonjour,
C'est tjs à cause du Set XlSheet = Nothing.

Code :

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

1
2
3
4
5
6
7
8
' Copie dans feuille (nouvelle ou effacée)
Set Rs = Db.OpenRecordset("T31_Cumul_Nvx_clients_par_BG", , dbOpenForwardOnly)
XlSheet.Range("A1").CopyFromRecordset Rs
Set XlSheet = Nothing
' remise au début car le 'CopyFromRecordset' ne le fait pas
Rs.MoveFirst
XlSheet.Range("A1").CopyFromRecordset Rs

Il faut le mettre après quand tu n'en as plus besoin ->

Code :

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

1
2
3
4
5
6
7
8
9
' Copie dans feuille (nouvelle ou effacée)
Set Rs = Db.OpenRecordset("T31_Cumul_Nvx_clients_par_BG", , dbOpenForwardOnly)
XlSheet.Range("A1").CopyFromRecordset Rs
' remise au début car le 'CopyFromRecordset' ne le fait pas
Rs.MoveFirst
XlSheet.Range("A1").CopyFromRecordset Rs
Set XlSheet = Nothing

Bonne continuation.

[PAULOM]

Bonjour,
C'est tjs à cause du Set XlSheet = Nothing.

Code :

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

1
2
3
4
5
6
7
8
' Copie dans feuille (nouvelle ou effacée)
Set Rs = Db.OpenRecordset("T31_Cumul_Nvx_clients_par_BG", , dbOpenForwardOnly)
XlSheet.Range("A1").CopyFromRecordset Rs
Set XlSheet = Nothing
' remise au début car le 'CopyFromRecordset' ne le fait pas
Rs.MoveFirst
XlSheet.Range("A1").CopyFromRecordset Rs

Il faut le mettre après quand tu n'en as plus besoin ->

Code :

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

1
2
3
4
5
6
7
8
9
' Copie dans feuille (nouvelle ou effacée)
Set Rs = Db.OpenRecordset("T31_Cumul_Nvx_clients_par_BG", , dbOpenForwardOnly)
XlSheet.Range("A1").CopyFromRecordset Rs
' remise au début car le 'CopyFromRecordset' ne le fait pas
Rs.MoveFirst
XlSheet.Range("A1").CopyFromRecordset Rs
Set XlSheet = Nothing

Bonne continuation.

Si je fais cela, ça me fait le meme problème qu'auparavant, des que je lance le module EXCEL ne réagit plus et j'ai une page grise, en faite toutes les feuilles du fichier excel se ferment, donc je sais pas quoi faire

Merci beaucoup de m'aider LedZeppII

[LedZeppII]

J'y comprends plus rien. Moi, ça marche avec office 2000 et 2003.

T31_Cumul_Nvx_clients_par_BG c'est une table ou une requête ?

Si je fais cela, ça me fait le meme problème qu'auparavant, des que je lance le module EXCEL ne réagit plus et j'ai une page grise, donc je sais pas quoi faire

Qu'est-ce que tu entends par page grise ?
- Excel ouvert mais pas de classeur ouvert ?
- Excel ouvert avec un classeur avec feuille vide ?

On peut essayer une dernière chose :

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
' (faire un Dim LigneCopiees as Long au début de la Sub)

' Copie dans feuille (nouvelle ou effacée)
If DCount("*", "T31_Cumul_Nvx_clients_par_BG") > 0 Then
    Set Db = CurrentDb
     ' Copie dans feuille (nouvelle ou effacée)
    Set Rs = Db.OpenRecordset("T31_Cumul_Nvx_clients_par_BG", , dbOpenForwardOnly)
    Rs.MoveFirst
    LigneCopiees = XlSheet.Range("A1").CopyFromRecordset(Rs)
     ' Ferme les Var
    Rs.Close: Set Rs = Nothing
    Db.Close: Set Db = Nothing
Else
    MsgBox "Pas de données"
End If

' Ferme les Var
Set XlSheet = Nothing
 ' Sauve le fichier
XlBook.Save
XlBook.Close
 ' Ferme les Var
Set XlBook = Nothing
Set Xlapp = Nothing

à la place du bout de code qui pose problème

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
' Copie dans feuille (nouvelle ou effacée)
Set Rs = Db.OpenRecordset("T31_Cumul_Nvx_clients_par_BG", , dbOpenForwardOnly)
XlSheet.Range("A1").CopyFromRecordset Rs
Set XlSheet = Nothing
' remise au début car le 'CopyFromRecordset' ne le fait pas
Rs.MoveFirst
XlSheet.Range("A1").CopyFromRecordset Rs
 
' Ferme les Var
Rs.Close: Set Rs = Nothing
Db.Close: Set Db = Nothing
Set XlSheet = Nothing
' Sauve le fichier
XlBook.Save
XlBook.Close
Set XlBook = Nothing
Set Xlapp = Nothing

Exécute la Sub pas à pas et avance en faisant Shift+F8 dans le code.
Quand la ligne Set XlSheet = Nothing est en surbrillance, positionne le curseur de la souris sur la variable LigneCopiees juste au dessus pour que le débogueur indique la valeur dans une info bulle.

Bon courage

[PAULOM]

Je vais répondre à toutes tes questions:

T31_Cumul_Nvx_clients_par_BG c'est une table ou une requête ?

C'est une table

Qu'est-ce que tu entends par page grise ?

Excel ouvert mais pas de classeur ouvert


J'ai essayé ton code et malheureusement l'erreur persiste, et j'ai cherché la valeur demandée avec Set XlSheet = Nothing elle est de 111.
J'te remet mon code on sait jamais.

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
Option Compare Database
 Sub ExportTblAccessInExcel()
Dim Db As DAO.Database
Dim Rs As DAO.Recordset
Dim Xlapp As Excel.Application
Dim XlBook As Excel.Workbook
Dim XlSheet As Excel.Worksheet
Dim NomFeuille As String
'Dim SemainePré As String
Dim LigneCopiees As Long
On Error GoTo errOuvrirExcel
Set Xlapp = GetObject(, "Excel.Application")
 'On Error GoTo oups:
On Error GoTo 0
Xlapp.Visible = True
NomFeuille = "S" & DatePart("ww", Date) - 1
'SemainePré = "S" & DatePart("ww", Date) - 2
Set XlBook = Xlapp.Workbooks.Open("C:\Documents and Settings\A4382\Bureau\stage\Nvx_clients_par_BG_2006_S14.xls")
'Set XlSheet = XlBook.Worksheets("S0")
'Set XlSheet = XlBook.Worksheets("Semaine S-1")
If FeuilleExiste(NomFeuille, XlBook) Then
  Set XlSheet = XlBook.Worksheets("NomFeuille")
   ' efface les données
   XlSheet.Cells.Clear
Else
   ' Ajouter nouvelle feuille en dernière position
   Set XlSheet = XlBook.Worksheets.Add(, XlBook.Worksheets(XlBook.Worksheets.Count - 2))
   XlSheet.Name = NomFeuille
 
End If
 
Set Db = CurrentDb
 
 ' Copie dans feuille (nouvelle ou effacée)
 
If DCount("*", "T31_Cumul_Nvx_clients_par_BG") > 0 Then
    Set Db = CurrentDb
     ' Copie dans feuille (nouvelle ou effacée)
    Set Rs = Db.OpenRecordset("T31_Cumul_Nvx_clients_par_BG", , dbOpenForwardOnly)
    Rs.MoveFirst
    LigneCopiees = XlSheet.Range("A1").CopyFromRecordset(Rs)
     ' Ferme les Var
    Rs.Close: Set Rs = Nothing
    Db.Close: Set Db = Nothing
Else
    MsgBox "Pas de données"
End If
 
 
 ' Ferme les Var
Set XlSheet = Nothing
 ' Sauve le fichier
XlBook.Save
XlBook.Close
Set XlBook = Nothing
Set Xlapp = Nothing
Exit Sub
errOuvrirExcel:
'Err 429 : Un serveur OLE Automation ne peut pas créer d'objet
' -> Excel n'est PAS encore ouvert.
If Err = 429 Then
Set Xlapp = CreateObject("Excel.Application")
Resume Next
End If
oups:
MsgBox Err.Number & " - " & Err.Description
 End Sub
 Function FeuilleExiste(NomFeuille As String, Classeur As Excel.Workbook) As Boolean
Dim errNum As Long, strName As String
  errNum = 0: Err.Clear
   On Error Resume Next
   strName = Classeur.Worksheets(NomFeuille).Name
   errNum = Err.Number
   On Error GoTo 0
   If errNum = 0 Then FeuilleExiste = True Else FeuilleExiste = False
End Function

Merci beaucoup pour ton aide

[LedZeppII]

Ok. J'ai l'impression que tout va bien.
111 signifie que 111 lignes ont été copiées.
Le classeur est fermé par ligne en rouge dans le code

Code :

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

1
2
3
4
5
6
7
8
9
 ' Ferme les Var
Set XlSheet = Nothing
 ' Sauve le fichier
XlBook.Save
XlBook.Close
Set XlBook = Nothing
Set Xlapp = Nothing
Exit Sub

Je penses que si tu la mets en commentaire le Classeur restera ouvert.
A+

[PAULOM]

Merci beaucoup c'est bien ça, c'est trop gentil de ta part....

[LedZeppII]

De rien.
D'autant plus que j'ai découvert la méthode CopyFromRecordset que je ne connaissais pas.
A une autre fois, sur le forum.

[PAULOM]

Salut LedZepp, comme tu connait bien mon code j'ai un autre obstacle .
Je n'arrive pas à copier le contenu d'une feuille EXCEL dans une autre feuille EXCEL du meme classeur.

Je dois transférer une table ACCESS vers EXCEL, bon ça j'y arrive je transfère ma table ACCESS (toute les semaines) vers la feuille EXCEL (SXX) et cette feuille ainsi créer doit être copier dans le meme classeur dans la feuille S0, en gros je dois avoir 2 feuilles identiques dans le meme classeur mais sous 2 noms différents, et j'aimerais également mettre mes champs si possible.

Si tu peux c'est pas grave je chercherai, j'te remercie pour ce que tu as fait.

[LedZeppII]

Bonsoir PAULOM,

J'ai ajouté un peu de code après la copie du recordset dans la feuille Sxx.
Le principe consiste à créer une copie de la feuille Sxx que l'on renomme en S0, en ayant au préalable supprimé la feuille S0.
Xlapp.DisplayAlerts = True/False sert à Activer/Inhiber les messages de confirmations de suppression d'Excel.
Dernière chose, la feuille S0 est toujours en première position.

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
If DCount("*", "T31_Cumul_Nvx_clients_par_BG") > 0 Then
    Set Db = CurrentDb
    Set Rs = Db.OpenRecordset("T31_Cumul_Nvx_clients_par_BG", , dbOpenForwardOnly)
    Rs.MoveFirst
     ' Copie dans feuille (nouvelle ou effacée)
    LigneCopiees = XlSheet.Range("A1").CopyFromRecordset(Rs)
     ' Supprime feuille S0 si elle existe
    If FeuilleExiste("S0", XlBook) Then
       Xlapp.DisplayAlerts = False
       XlBook.Worksheets("S0").Delete
       Xlapp.DisplayAlerts = True
    End If
    ' Crée une copie de la feuille Sxx et la renomme S0
    XlSheet.Copy XlBook.Worksheets(1)
    XlBook.Worksheets(1).Name = "S0"
     ' Ferme les Var
    Rs.Close: Set Rs = Nothing
    Db.Close: Set Db = Nothing
Else
    MsgBox "Pas de données"
End If

Bonne continuation.

[PAULOM]

Merci LedZeppII, j'ai un peu modifier mon code mais je sais pas si "ça va tenir" comparer au tiens, car je l'ai fait à partir des macros d'Excel:J'ai également affiché les champs de la table

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
 
If DCount("*", "T31_Cumul_Nvx_clients_par_BG") > 0 Then
    Set Db = CurrentDb
     ' Copie dans feuille (nouvelle ou effacée)
    Set Rs = Db.OpenRecordset("T31_Cumul_Nvx_clients_par_BG", , dbOpenForwardOnly)
    For I = 0 To Rs.Fields.Count - 1
    XlSheet.Cells(1, I + 1) = Rs.Fields(I).Name
    Next I
    Rs.MoveFirst
    LigneCopiees = XlSheet.Range("A2").CopyFromRecordset(Rs)
     ' Ferme les Var
    Rs.Close: Set Rs = Nothing
    Db.Close: Set Db = Nothing
Else
    MsgBox "Pas de données"
End If
    'copie SXX dans S0
    Sheets(NomFeuille).Select
    Range("A1:G1").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWorkbook.Names.Add Name:="Semaine", RefersToR1C1:="=S16!R1C1:R111C7"
    Sheets(NomFeuille).Select
    Selection.Copy
    Sheets("S0").Select
    Range("A1:A1").Select
    ActiveSheet.Paste
    ActiveSheet.Paste

[LedZeppII]

Bonjour PAULOM,

Effectivement l'enregistrement de macros Excel produit un code avec beaucoup de références absolues.
Ce code n'est donc valable qu'à un instant donné.

J'ai modifié le code de mon dernier Post, pour qu'il copie les noms de champs du recordset.
J'ai aussi ajouté un volet pour que la ligne 1 ne bouge pas.
Seules les lignes 2 et plus pourront défiler verticalement.

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
If DCount("*", "T31_Cumul_Nvx_clients_par_BG") > 0 Then
   Set Db = CurrentDb
   Set Rs = Db.OpenRecordset("T31_Cumul_Nvx_clients_par_BG", , dbOpenForwardOnly)
   Rs.MoveFirst
   ' Copie en-tête colonnes
   For i = 0 To Rs.Fields.Count - 1
       XlSheet.Range("A1").Offset(0, i) = Rs.Fields(i).Name
       XlSheet.Range("A1").Offset(0, i).Font.Bold = True   ' En gras
       XlSheet.Range("A1").Offset(0, i).Interior.Color = vbYellow ' fond jaune
    Next
   ' Copie données dans feuille (nouvelle ou effacée)
   LigneCopiees = XlSheet.Range("A2").CopyFromRecordset(Rs)
   ' Figer les volets
   XlSheet.Activate
   XlSheet.Range("A2").Select
   Xlapp.ActiveWindow.FreezePanes = True
   ' Largeur colonnes auto
   XlSheet.Range("A1", XlSheet.Range("A1").Offset(LigneCopiees, i).Address).Columns.AutoFit
   ' Supprime feuille S0 si elle existe
   If FeuilleExiste("S0", XlBook) Then
      Xlapp.DisplayAlerts = False
      XlBook.Worksheets("S0").Delete
      Xlapp.DisplayAlerts = True
   End If
   ' Crée une copie de la feuille Sxx et la renomme S0
   XlSheet.Copy Before:=XlBook.Worksheets(1)
   XlBook.Worksheets(1).Name = "S0"
   ' Ferme les Var
   Rs.Close: Set Rs = Nothing
   Db.Close: Set Db = Nothing
Else
   MsgBox "Pas de données"
End If

Bonne continuation.