Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Access errreur 91 lors de transfers de données en Excel

errreur 91 lors de transfers de données en Excel

4 réponses
Avatar
Gaya
Bonjour a vous tous,

Sous access 2003, je transfers en vb des enregistrements dans un fichier
excel et j'ai une forme conditonnelle a appliquer .
Lorsque j'exécute la première fois tout est ok mais si je réexécute une
secondes fois, j'obtiens l'erreur 91.

Pour régler je dois fermer la BD et repartir. encore la je pense seulement
qu'une fois et la seconde fois ça ne marche pas.

Je plante à la ligne :
Selection.FormatConditions.Delete

Voici mon code :


Private Sub cmdGenerateExcelFile_Click()
On Error GoTo GestionErreur
Dim db As Database
Dim rstSousProjets As Recordset
Dim strsql As String
Dim strSheetName As String
Dim strfiltre, intColonne As String
Dim flgExcelOuvert As Boolean
Dim flgWbkOuvert As Boolean

Dim intFeuil As Integer, strTemplate As String
Dim countrecord, intLigne

DoCmd.Hourglass True

If Me.cboProduit <> "" And Not IsNull(Me.cboProduit) Then
strfiltre = "Produit = '" & Replace(Me.cboProduit, "'", "''") & "'"
End If

If Me.cboAnneeModele <> "" And Not IsNull(Me.cboAnneeModele) Then
If strfiltre <> "" Then
strfiltre = strfiltre & " AND "
End If
strfiltre = strfiltre & "MY = " & Me.cboAnneeModele
End If

If Me.modProjet <> "" And Not IsNull(Me.modProjet) Then
If strfiltre <> "" Then
strfiltre = strfiltre & " AND "
End If
strfiltre = strfiltre & "Titre = '" & Replace(Me.modProjet, "'",
"''") & "'"
End If

If Not IsNull(Me.mdStatusProjet) And Me.mdStatusProjet <> "" Then
If Me.mdStatusProjet = "Reçue" Then
strfiltre = strfiltre & " AND [Date reçue] is not null"
Else
strfiltre = strfiltre & " AND [Date reçue] is null"
End If
End If

If Me.ModTerme.Column(1) <> "" And Not IsNull(Me.ModTerme.Column(1)) Then
If strfiltre <> "" Then
strfiltre = strfiltre & " AND "
End If
strfiltre = strfiltre & "[Lt(1) - CT(2)] = " & Me.ModTerme.Column(1)
End If

If strfiltre <> "" Then
strfiltre = "WHERE " & strfiltre
End If

'************************************************************************
' Changer la cible selon où est placé le fichier template
'************************************************************************
strTemplate = "C:\Projets\Gestion de Projet\Approval.xls"

Set db = CurrentDb()
Dim rstProjets As Recordset
Set rstProjets = db.OpenRecordset("SELECT [Projet Principal].Titre " & _
"FROM ([Projet Principal] LEFT JOIN
[Type pub tech] ON [Projet Principal].FkTypePubTech = [Type pub tech].[No
type pub tech]) INNER JOIN ([Liste employé] RIGHT JOIN (([Sous-projet] LEFT
JOIN TbSousTypesPubTech ON [Sous-projet].FkSousTypePubTech =
TbSousTypesPubTech.PkSousTypePubTech) LEFT JOIN [suivi date] ON
[Sous-projet].[No S-projet] = [suivi date].[s-projet]) ON [Liste employé].[No
employé] = [Sous-projet].[Resp Rédaction]) ON [Projet Principal].[No Projet
principal] = [Sous-projet].[No projet principal] " & _
strfiltre & _
" GROUP BY [Projet Principal].Titre "
& _
"ORDER BY [Projet Principal].Titre;")

If rstProjets.EOF Then
MsgBox ("Aucun résultat disponible pour votre sélection")
Else

Dim XL As New Excel.Application
Dim wbk As Excel.Workbook

flgExcelOuvert = True

XL.Visible = True

Set wbk = XL.Workbooks.Add(strTemplate)
flgWbkOuvert = True

intFeuil = 1
rstProjets.MoveFirst

strSheetName = Left$(rstProjets("Titre"), 31)
strSheetName = Replace([strSheetName], "/", " ")
strSheetName = Replace([strSheetName], "*", " ")
strSheetName = Replace([strSheetName], "\", " ")
strSheetName = Replace([strSheetName], "?", " ")
wbk.Sheets(intFeuil).name = strSheetName
wbk.Sheets(intFeuil).Range("A2") = rstProjets("Titre")

rstProjets.MoveNext
While Not rstProjets.EOF
wbk.Sheets(1).Copy After:=wbk.Sheets(intFeuil)
intFeuil = intFeuil + 1
wbk.Sheets(intFeuil).Range("A2") = rstProjets("Titre")

strSheetName = Left$(rstProjets("Titre"), 31)
strSheetName = Replace([strSheetName], "/", " ")
strSheetName = Replace([strSheetName], "*", " ")
strSheetName = Replace([strSheetName], "\", " ")
strSheetName = Replace([strSheetName], "?", " ")
wbk.Sheets(intFeuil).name = strSheetName


Set rstSousProjets = db.OpenRecordset("SELECT [Sous-projet].[No
S-projet SAV], [Sous-projet].Description, ([prenom] & ' ' & [nom]) AS
Responsable, [suivi date].contact, [suivi date].[date envoyé], [suivi
date].[Date butoir], [suivi date].[date reçue] " & _
"FROM ([Projet Principal] LEFT JOIN [Type
pub tech] ON [Projet Principal].FkTypePubTech = [Type pub tech].[No type pub
tech]) INNER JOIN ([Liste employé] RIGHT JOIN (([Sous-projet] LEFT JOIN
TbSousTypesPubTech ON [Sous-projet].FkSousTypePubTech =
TbSousTypesPubTech.PkSousTypePubTech) LEFT JOIN [suivi date] ON
[Sous-projet].[No S-projet] = [suivi date].[s-projet]) ON[Liste employé].[No
employé] = [Sous-projet].[Resp Rédaction]) ON [Projet Principal].[No Projet
principal] = [Sous-projet].[No projet principal] " & _
strfiltre & " AND [Projet Principal].Titre =
'" & Replace(rstProjets("Titre"), "'", "''") & "' " & _
"Order By [Sous-projet].[No S-projet SAV]")

wbk.Sheets(strSheetName).Columns("B:B").WrapText = True

intLigne = 6

While Not rstSousProjets.EOF
With wbk.Sheets(strSheetName)
.Range("A" & intLigne).Value = rstSousProjets("No S-projet
SAV")
.Range("B" & intLigne).Value = rstSousProjets("DESCRIPTION")
.Range("C" & intLigne).Value = rstSousProjets("Contact")
.Range("D" & intLigne).Value = rstSousProjets("Responsable")
.Range("E" & intLigne).Value = rstSousProjets("Date Envoyé")
.Range("F" & intLigne).Value = rstSousProjets("Date Butoir")
.Range("G" & intLigne).Value = rstSousProjets("Date Reçue")

.Range("E" & intLigne).NumberFormat = "yyyy/mm/dd;@"
.Range("F" & intLigne).NumberFormat = "yyyy/mm/dd;@"
.Range("G" & intLigne).NumberFormat = "yyyy/mm/dd;@"

.Range("G" & intLigne).Select
Selection.FormatConditions.Delete
Selection.FormatConditions.Add type:=xlCellValue,
Operator:=xlGreater, Formula1:="=F" & intLigne

With Selection.FormatConditions(1).Font
.Bold = True
.Italic = False
.ColorIndex = 3
End With
Selection.FormatConditions.Add type:=xlCellValue,
Operator:=xlLess, Formula1:="=F" & intLigne
With Selection.FormatConditions(2).Font
.Bold = True
.Italic = False
.ColorIndex = 10
End With
End With
rstSousProjets.MoveNext
intLigne = intLigne + 1
Wend

rstSousProjets.Close
Set rstSousProjets = Nothing
rstProjets.MoveNext
Wend
'pour finir, on rempli la feuille 1 qui nous servait de template. On
la gardait vide pour la copier.
rstProjets.MoveFirst
Set rstSousProjets = db.OpenRecordset("SELECT [Sous-projet].[No
S-projet SAV], [Sous-projet].Description, ([prenom] & ' ' & [nom]) AS
Responsable, [suivi date].contact, format([suivi date].[date
envoyé],'yyyy-mm-dd'), format([suivi date].[Date butoir],'yyyy-mm-dd'),
format([suivi date].[date reçue],'yyyy-mm-dd') " & _
"FROM ([Projet Principal] LEFT JOIN [Type
pub tech] ON [Projet Principal].FkTypePubTech = [Type pub tech].[No type pub
tech]) INNER JOIN ([Liste employé] RIGHT JOIN (([Sous-projet] LEFT JOIN
TbSousTypesPubTech ON [Sous-projet].FkSousTypePubTech =
TbSousTypesPubTech.PkSousTypePubTech) LEFT JOIN [suivi date] ON
[Sous-projet].[No S-projet] = [suivi date].[s-projet]) ON[Liste employé].[No
employé] = [Sous-projet].[Resp Rédaction]) ON [Projet Principal].[No Projet
principal] = [Sous-projet].[No projet principal] " & _
strfiltre & " AND [Projet
Principal].Titre = '" & Replace(rstProjets("Titre"), "'", "''") & "' " & _
"Order By [Sous-projet].[No S-projet SAV]")
wbk.Sheets(1).Range("A6").CopyFromRecordset rstSousProjets
wbk.Sheets(1).Columns("B:B").WrapText = True
wbk.Sheets(1).Select
wbk.Sheets(1).Cells(1, 1).Select

XL.Visible = True

Set XL = Nothing
rstProjets.Close
Set rstProjets = Nothing
Set db = Nothing
Set wbk = Nothing

End If

DoCmd.Hourglass False
Exit Sub
GestionErreur:
DoCmd.Hourglass False
If flgWbkOuvert = True Then
wbk.Close False
Set wbk = Nothing
End If
If flgExcelOuvert = True Then
XL.Quit
Set XL = Nothing
End If
If Err.Number <> 2501 Then
MsgBox Err.Number & " " & Err.Description
Else
MsgBox "Il n'y a pas de données pour les paramètres demandés.",
vbInformation
End If

End Sub


merci de m'aider car ça fair des heures que je piétine.

cordialement
Signaler un problème avec ce contenu

4 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Avatar
Gilbert
Bonjour,

As-tu essayé de remplacer
Selection.FormatConditions.Delete
Selection.FormatConditions.Add type:=xlCellValue, Operator:=xlGreater,
Formula1:="=F" & intLigne
par
Selection.FormatConditions.Modify type:=xlCellValue, Operator:=xlGreater,
Formula1:="=F" & intLigne
?
--
Cordialement,

Gilbert


"Gaya" a écrit dans le message de
news:
Bonjour a vous tous,

Sous access 2003, je transfers en vb des enregistrements dans un fichier
excel et j'ai une forme conditonnelle a appliquer .
Lorsque j'exécute la première fois tout est ok mais si je réexécute une
secondes fois, j'obtiens l'erreur 91.

Pour régler je dois fermer la BD et repartir. encore la je pense seulement
qu'une fois et la seconde fois ça ne marche pas.

Je plante à la ligne :
Selection.FormatConditions.Delete

Voici mon code :


Private Sub cmdGenerateExcelFile_Click()
On Error GoTo GestionErreur
Dim db As Database
Dim rstSousProjets As Recordset
Dim strsql As String
Dim strSheetName As String
Dim strfiltre, intColonne As String
Dim flgExcelOuvert As Boolean
Dim flgWbkOuvert As Boolean

Dim intFeuil As Integer, strTemplate As String
Dim countrecord, intLigne

DoCmd.Hourglass True

If Me.cboProduit <> "" And Not IsNull(Me.cboProduit) Then
strfiltre = "Produit = '" & Replace(Me.cboProduit, "'", "''") &


"'"
End If

If Me.cboAnneeModele <> "" And Not IsNull(Me.cboAnneeModele) Then
If strfiltre <> "" Then
strfiltre = strfiltre & " AND "
End If
strfiltre = strfiltre & "MY = " & Me.cboAnneeModele
End If

If Me.modProjet <> "" And Not IsNull(Me.modProjet) Then
If strfiltre <> "" Then
strfiltre = strfiltre & " AND "
End If
strfiltre = strfiltre & "Titre = '" & Replace(Me.modProjet, "'",
"''") & "'"
End If

If Not IsNull(Me.mdStatusProjet) And Me.mdStatusProjet <> "" Then
If Me.mdStatusProjet = "Reçue" Then
strfiltre = strfiltre & " AND [Date reçue] is not null"
Else
strfiltre = strfiltre & " AND [Date reçue] is null"
End If
End If

If Me.ModTerme.Column(1) <> "" And Not IsNull(Me.ModTerme.Column(1))


Then
If strfiltre <> "" Then
strfiltre = strfiltre & " AND "
End If
strfiltre = strfiltre & "[Lt(1) - CT(2)] = " &


Me.ModTerme.Column(1)
End If

If strfiltre <> "" Then
strfiltre = "WHERE " & strfiltre
End If

'************************************************************************
' Changer la cible selon où est placé le fichier template
'************************************************************************
strTemplate = "C:ProjetsGestion de ProjetApproval.xls"

Set db = CurrentDb()
Dim rstProjets As Recordset
Set rstProjets = db.OpenRecordset("SELECT [Projet Principal].Titre "


& _
"FROM ([Projet Principal] LEFT JOIN
[Type pub tech] ON [Projet Principal].FkTypePubTech = [Type pub tech].[No
type pub tech]) INNER JOIN ([Liste employé] RIGHT JOIN (([Sous-projet]


LEFT
JOIN TbSousTypesPubTech ON [Sous-projet].FkSousTypePubTech > TbSousTypesPubTech.PkSousTypePubTech) LEFT JOIN [suivi date] ON
[Sous-projet].[No S-projet] = [suivi date].[s-projet]) ON [Liste


employé].[No
employé] = [Sous-projet].[Resp Rédaction]) ON [Projet Principal].[No


Projet
principal] = [Sous-projet].[No projet principal] " & _
strfiltre & _
" GROUP BY [Projet Principal].Titre


"
& _
"ORDER BY [Projet


Principal].Titre;")

If rstProjets.EOF Then
MsgBox ("Aucun résultat disponible pour votre sélection")
Else

Dim XL As New Excel.Application
Dim wbk As Excel.Workbook

flgExcelOuvert = True

XL.Visible = True

Set wbk = XL.Workbooks.Add(strTemplate)
flgWbkOuvert = True

intFeuil = 1
rstProjets.MoveFirst

strSheetName = Left$(rstProjets("Titre"), 31)
strSheetName = Replace([strSheetName], "/", " ")
strSheetName = Replace([strSheetName], "*", " ")
strSheetName = Replace([strSheetName], "", " ")
strSheetName = Replace([strSheetName], "?", " ")
wbk.Sheets(intFeuil).name = strSheetName
wbk.Sheets(intFeuil).Range("A2") = rstProjets("Titre")

rstProjets.MoveNext
While Not rstProjets.EOF
wbk.Sheets(1).Copy After:=wbk.Sheets(intFeuil)
intFeuil = intFeuil + 1
wbk.Sheets(intFeuil).Range("A2") = rstProjets("Titre")

strSheetName = Left$(rstProjets("Titre"), 31)
strSheetName = Replace([strSheetName], "/", " ")
strSheetName = Replace([strSheetName], "*", " ")
strSheetName = Replace([strSheetName], "", " ")
strSheetName = Replace([strSheetName], "?", " ")
wbk.Sheets(intFeuil).name = strSheetName


Set rstSousProjets = db.OpenRecordset("SELECT


[Sous-projet].[No
S-projet SAV], [Sous-projet].Description, ([prenom] & ' ' & [nom]) AS
Responsable, [suivi date].contact, [suivi date].[date envoyé], [suivi
date].[Date butoir], [suivi date].[date reçue] " & _
"FROM ([Projet Principal] LEFT JOIN [Type
pub tech] ON [Projet Principal].FkTypePubTech = [Type pub tech].[No type


pub
tech]) INNER JOIN ([Liste employé] RIGHT JOIN (([Sous-projet] LEFT JOIN
TbSousTypesPubTech ON [Sous-projet].FkSousTypePubTech > TbSousTypesPubTech.PkSousTypePubTech) LEFT JOIN [suivi date] ON
[Sous-projet].[No S-projet] = [suivi date].[s-projet]) ON[Liste


employé].[No
employé] = [Sous-projet].[Resp Rédaction]) ON [Projet Principal].[No


Projet
principal] = [Sous-projet].[No projet principal] " & _
strfiltre & " AND [Projet Principal].Titre


> '" & Replace(rstProjets("Titre"), "'", "''") & "' " & _
"Order By [Sous-projet].[No S-projet


SAV]")

wbk.Sheets(strSheetName).Columns("B:B").WrapText = True

intLigne = 6

While Not rstSousProjets.EOF
With wbk.Sheets(strSheetName)
.Range("A" & intLigne).Value = rstSousProjets("No S-projet
SAV")
.Range("B" & intLigne).Value rstSousProjets("DESCRIPTION")
.Range("C" & intLigne).Value = rstSousProjets("Contact")
.Range("D" & intLigne).Value rstSousProjets("Responsable")
.Range("E" & intLigne).Value = rstSousProjets("Date


Envoyé")
.Range("F" & intLigne).Value = rstSousProjets("Date


Butoir")
.Range("G" & intLigne).Value = rstSousProjets("Date


Reçue")

.Range("E" & intLigne).NumberFormat = "yyyy/mm/dd;@"
.Range("F" & intLigne).NumberFormat = "yyyy/mm/dd;@"
.Range("G" & intLigne).NumberFormat = "yyyy/mm/dd;@"

.Range("G" & intLigne).Select
Selection.FormatConditions.Delete
Selection.FormatConditions.Add type:=xlCellValue,
Operator:=xlGreater, Formula1:="=F" & intLigne

With Selection.FormatConditions(1).Font
.Bold = True
.Italic = False
.ColorIndex = 3
End With
Selection.FormatConditions.Add type:=xlCellValue,
Operator:=xlLess, Formula1:="=F" & intLigne
With Selection.FormatConditions(2).Font
.Bold = True
.Italic = False
.ColorIndex = 10
End With
End With
rstSousProjets.MoveNext
intLigne = intLigne + 1
Wend

rstSousProjets.Close
Set rstSousProjets = Nothing
rstProjets.MoveNext
Wend
'pour finir, on rempli la feuille 1 qui nous servait de template.


On
la gardait vide pour la copier.
rstProjets.MoveFirst
Set rstSousProjets = db.OpenRecordset("SELECT [Sous-projet].[No
S-projet SAV], [Sous-projet].Description, ([prenom] & ' ' & [nom]) AS
Responsable, [suivi date].contact, format([suivi date].[date
envoyé],'yyyy-mm-dd'), format([suivi date].[Date butoir],'yyyy-mm-dd'),
format([suivi date].[date reçue],'yyyy-mm-dd') " & _
"FROM ([Projet Principal] LEFT JOIN


[Type
pub tech] ON [Projet Principal].FkTypePubTech = [Type pub tech].[No type


pub
tech]) INNER JOIN ([Liste employé] RIGHT JOIN (([Sous-projet] LEFT JOIN
TbSousTypesPubTech ON [Sous-projet].FkSousTypePubTech > TbSousTypesPubTech.PkSousTypePubTech) LEFT JOIN [suivi date] ON
[Sous-projet].[No S-projet] = [suivi date].[s-projet]) ON[Liste


employé].[No
employé] = [Sous-projet].[Resp Rédaction]) ON [Projet Principal].[No


Projet
principal] = [Sous-projet].[No projet principal] " & _
strfiltre & " AND [Projet
Principal].Titre = '" & Replace(rstProjets("Titre"), "'", "''") & "' " & _
"Order By [Sous-projet].[No S-projet


SAV]")
wbk.Sheets(1).Range("A6").CopyFromRecordset rstSousProjets
wbk.Sheets(1).Columns("B:B").WrapText = True
wbk.Sheets(1).Select
wbk.Sheets(1).Cells(1, 1).Select

XL.Visible = True

Set XL = Nothing
rstProjets.Close
Set rstProjets = Nothing
Set db = Nothing
Set wbk = Nothing

End If

DoCmd.Hourglass False
Exit Sub
GestionErreur:
DoCmd.Hourglass False
If flgWbkOuvert = True Then
wbk.Close False
Set wbk = Nothing
End If
If flgExcelOuvert = True Then
XL.Quit
Set XL = Nothing
End If
If Err.Number <> 2501 Then
MsgBox Err.Number & " " & Err.Description
Else
MsgBox "Il n'y a pas de données pour les paramètres demandés.",
vbInformation
End If

End Sub


merci de m'aider car ça fair des heures que je piétine.

cordialement



Avatar
Gaya
Bonsoir gilbert,

Je viens d'essayer ta suggestion et malheureusement j'ai maintenant l'erreur:

438 propriété ou méthode non géré par l'objet.



"Gilbert" a écrit :

Bonjour,

As-tu essayé de remplacer
Selection.FormatConditions.Delete
Selection.FormatConditions.Add type:=xlCellValue, Operator:=xlGreater,
Formula1:="=F" & intLigne
par
Selection.FormatConditions.Modify type:=xlCellValue, Operator:=xlGreater,
Formula1:="=F" & intLigne
?
--
Cordialement,

Gilbert


"Gaya" a écrit dans le message de
news:
> Bonjour a vous tous,
>
> Sous access 2003, je transfers en vb des enregistrements dans un fichier
> excel et j'ai une forme conditonnelle a appliquer .
> Lorsque j'exécute la première fois tout est ok mais si je réexécute une
> secondes fois, j'obtiens l'erreur 91.
>
> Pour régler je dois fermer la BD et repartir. encore la je pense seulement
> qu'une fois et la seconde fois ça ne marche pas.
>
> Je plante à la ligne :
> Selection.FormatConditions.Delete
>
> Voici mon code :
>
>
> Private Sub cmdGenerateExcelFile_Click()
> On Error GoTo GestionErreur
> Dim db As Database
> Dim rstSousProjets As Recordset
> Dim strsql As String
> Dim strSheetName As String
> Dim strfiltre, intColonne As String
> Dim flgExcelOuvert As Boolean
> Dim flgWbkOuvert As Boolean
>
> Dim intFeuil As Integer, strTemplate As String
> Dim countrecord, intLigne
>
> DoCmd.Hourglass True
>
> If Me.cboProduit <> "" And Not IsNull(Me.cboProduit) Then
> strfiltre = "Produit = '" & Replace(Me.cboProduit, "'", "''") &
"'"
> End If
>
> If Me.cboAnneeModele <> "" And Not IsNull(Me.cboAnneeModele) Then
> If strfiltre <> "" Then
> strfiltre = strfiltre & " AND "
> End If
> strfiltre = strfiltre & "MY = " & Me.cboAnneeModele
> End If
>
> If Me.modProjet <> "" And Not IsNull(Me.modProjet) Then
> If strfiltre <> "" Then
> strfiltre = strfiltre & " AND "
> End If
> strfiltre = strfiltre & "Titre = '" & Replace(Me.modProjet, "'",
> "''") & "'"
> End If
>
> If Not IsNull(Me.mdStatusProjet) And Me.mdStatusProjet <> "" Then
> If Me.mdStatusProjet = "Reçue" Then
> strfiltre = strfiltre & " AND [Date reçue] is not null"
> Else
> strfiltre = strfiltre & " AND [Date reçue] is null"
> End If
> End If
>
> If Me.ModTerme.Column(1) <> "" And Not IsNull(Me.ModTerme.Column(1))
Then
> If strfiltre <> "" Then
> strfiltre = strfiltre & " AND "
> End If
> strfiltre = strfiltre & "[Lt(1) - CT(2)] = " &
Me.ModTerme.Column(1)
> End If
>
> If strfiltre <> "" Then
> strfiltre = "WHERE " & strfiltre
> End If
>
> '************************************************************************
> ' Changer la cible selon où est placé le fichier template
> '************************************************************************
> strTemplate = "C:ProjetsGestion de ProjetApproval.xls"
>
> Set db = CurrentDb()
> Dim rstProjets As Recordset
> Set rstProjets = db.OpenRecordset("SELECT [Projet Principal].Titre "
& _
> "FROM ([Projet Principal] LEFT JOIN
> [Type pub tech] ON [Projet Principal].FkTypePubTech = [Type pub tech].[No
> type pub tech]) INNER JOIN ([Liste employé] RIGHT JOIN (([Sous-projet]
LEFT
> JOIN TbSousTypesPubTech ON [Sous-projet].FkSousTypePubTech > > TbSousTypesPubTech.PkSousTypePubTech) LEFT JOIN [suivi date] ON
> [Sous-projet].[No S-projet] = [suivi date].[s-projet]) ON [Liste
employé].[No
> employé] = [Sous-projet].[Resp Rédaction]) ON [Projet Principal].[No
Projet
> principal] = [Sous-projet].[No projet principal] " & _
> strfiltre & _
> " GROUP BY [Projet Principal].Titre
"
> & _
> "ORDER BY [Projet
Principal].Titre;")
>
> If rstProjets.EOF Then
> MsgBox ("Aucun résultat disponible pour votre sélection")
> Else
>
> Dim XL As New Excel.Application
> Dim wbk As Excel.Workbook
>
> flgExcelOuvert = True
>
> XL.Visible = True
>
> Set wbk = XL.Workbooks.Add(strTemplate)
> flgWbkOuvert = True
>
> intFeuil = 1
> rstProjets.MoveFirst
>
> strSheetName = Left$(rstProjets("Titre"), 31)
> strSheetName = Replace([strSheetName], "/", " ")
> strSheetName = Replace([strSheetName], "*", " ")
> strSheetName = Replace([strSheetName], "", " ")
> strSheetName = Replace([strSheetName], "?", " ")
> wbk.Sheets(intFeuil).name = strSheetName
> wbk.Sheets(intFeuil).Range("A2") = rstProjets("Titre")
>
> rstProjets.MoveNext
> While Not rstProjets.EOF
> wbk.Sheets(1).Copy After:=wbk.Sheets(intFeuil)
> intFeuil = intFeuil + 1
> wbk.Sheets(intFeuil).Range("A2") = rstProjets("Titre")
>
> strSheetName = Left$(rstProjets("Titre"), 31)
> strSheetName = Replace([strSheetName], "/", " ")
> strSheetName = Replace([strSheetName], "*", " ")
> strSheetName = Replace([strSheetName], "", " ")
> strSheetName = Replace([strSheetName], "?", " ")
> wbk.Sheets(intFeuil).name = strSheetName
>
>
> Set rstSousProjets = db.OpenRecordset("SELECT
[Sous-projet].[No
> S-projet SAV], [Sous-projet].Description, ([prenom] & ' ' & [nom]) AS
> Responsable, [suivi date].contact, [suivi date].[date envoyé], [suivi
> date].[Date butoir], [suivi date].[date reçue] " & _
> "FROM ([Projet Principal] LEFT JOIN [Type
> pub tech] ON [Projet Principal].FkTypePubTech = [Type pub tech].[No type
pub
> tech]) INNER JOIN ([Liste employé] RIGHT JOIN (([Sous-projet] LEFT JOIN
> TbSousTypesPubTech ON [Sous-projet].FkSousTypePubTech > > TbSousTypesPubTech.PkSousTypePubTech) LEFT JOIN [suivi date] ON
> [Sous-projet].[No S-projet] = [suivi date].[s-projet]) ON[Liste
employé].[No
> employé] = [Sous-projet].[Resp Rédaction]) ON [Projet Principal].[No
Projet
> principal] = [Sous-projet].[No projet principal] " & _
> strfiltre & " AND [Projet Principal].Titre
> > '" & Replace(rstProjets("Titre"), "'", "''") & "' " & _
> "Order By [Sous-projet].[No S-projet
SAV]")
>
> wbk.Sheets(strSheetName).Columns("B:B").WrapText = True
>
> intLigne = 6
>
> While Not rstSousProjets.EOF
> With wbk.Sheets(strSheetName)
> .Range("A" & intLigne).Value = rstSousProjets("No S-projet
> SAV")
> .Range("B" & intLigne).Value > rstSousProjets("DESCRIPTION")
> .Range("C" & intLigne).Value = rstSousProjets("Contact")
> .Range("D" & intLigne).Value > rstSousProjets("Responsable")
> .Range("E" & intLigne).Value = rstSousProjets("Date
Envoyé")
> .Range("F" & intLigne).Value = rstSousProjets("Date
Butoir")
> .Range("G" & intLigne).Value = rstSousProjets("Date
Reçue")
>
> .Range("E" & intLigne).NumberFormat = "yyyy/mm/dd;@"
> .Range("F" & intLigne).NumberFormat = "yyyy/mm/dd;@"
> .Range("G" & intLigne).NumberFormat = "yyyy/mm/dd;@"
>
> .Range("G" & intLigne).Select
> Selection.FormatConditions.Delete
> Selection.FormatConditions.Add type:=xlCellValue,
> Operator:=xlGreater, Formula1:="=F" & intLigne
>
> With Selection.FormatConditions(1).Font
> .Bold = True
> .Italic = False
> .ColorIndex = 3
> End With
> Selection.FormatConditions.Add type:=xlCellValue,
> Operator:=xlLess, Formula1:="=F" & intLigne
> With Selection.FormatConditions(2).Font
> .Bold = True
> .Italic = False
> .ColorIndex = 10
> End With
> End With
> rstSousProjets.MoveNext
> intLigne = intLigne + 1
> Wend
>
> rstSousProjets.Close
> Set rstSousProjets = Nothing
> rstProjets.MoveNext
> Wend
> 'pour finir, on rempli la feuille 1 qui nous servait de template.
On
> la gardait vide pour la copier.
> rstProjets.MoveFirst
> Set rstSousProjets = db.OpenRecordset("SELECT [Sous-projet].[No
> S-projet SAV], [Sous-projet].Description, ([prenom] & ' ' & [nom]) AS
> Responsable, [suivi date].contact, format([suivi date].[date
> envoyé],'yyyy-mm-dd'), format([suivi date].[Date butoir],'yyyy-mm-dd'),
> format([suivi date].[date reçue],'yyyy-mm-dd') " & _
> "FROM ([Projet Principal] LEFT JOIN
[Type
> pub tech] ON [Projet Principal].FkTypePubTech = [Type pub tech].[No type
pub
> tech]) INNER JOIN ([Liste employé] RIGHT JOIN (([Sous-projet] LEFT JOIN
> TbSousTypesPubTech ON [Sous-projet].FkSousTypePubTech > > TbSousTypesPubTech.PkSousTypePubTech) LEFT JOIN [suivi date] ON
> [Sous-projet].[No S-projet] = [suivi date].[s-projet]) ON[Liste
employé].[No
> employé] = [Sous-projet].[Resp Rédaction]) ON [Projet Principal].[No
Projet
> principal] = [Sous-projet].[No projet principal] " & _
> strfiltre & " AND [Projet
> Principal].Titre = '" & Replace(rstProjets("Titre"), "'", "''") & "' " & _
> "Order By [Sous-projet].[No S-projet
SAV]")
> wbk.Sheets(1).Range("A6").CopyFromRecordset rstSousProjets
> wbk.Sheets(1).Columns("B:B").WrapText = True
> wbk.Sheets(1).Select
> wbk.Sheets(1).Cells(1, 1).Select
>
> XL.Visible = True
>
> Set XL = Nothing
> rstProjets.Close
> Set rstProjets = Nothing
> Set db = Nothing
> Set wbk = Nothing
>
> End If
>
> DoCmd.Hourglass False
> Exit Sub
> GestionErreur:
> DoCmd.Hourglass False
> If flgWbkOuvert = True Then
> wbk.Close False
> Set wbk = Nothing
> End If
> If flgExcelOuvert = True Then
> XL.Quit
> Set XL = Nothing
> End If
> If Err.Number <> 2501 Then
> MsgBox Err.Number & " " & Err.Description
> Else
> MsgBox "Il n'y a pas de données pour les paramètres demandés.",
> vbInformation
> End If
>
> End Sub
>
>
> merci de m'aider car ça fair des heures que je piétine.
>
> cordialement
>





Avatar
Gilbert
Tu dis que l'erreur se produit à la 2° exécution de la procédure. La
commande Selection.FormatConditions.Delete étant dans une boucle, as-tu
regardé à quel moment se produit l'erreur? Dès le premier passage? lors du
dernier? au milieu? Ce peut être un indice.

Il te faudrait peut-être essayer d'exécuter en pas à pas en contrôlant au
fur et à mesure ton fichier Excel.

--
Cordialement,

Gilbert


"Gaya" a écrit dans le message de
news:
Bonsoir gilbert,

Je viens d'essayer ta suggestion et malheureusement j'ai maintenant


l'erreur:

438 propriété ou méthode non géré par l'objet.



"Gilbert" a écrit :

> Bonjour,
>
> As-tu essayé de remplacer
> Selection.FormatConditions.Delete
> Selection.FormatConditions.Add type:=xlCellValue, Operator:=xlGreater,
> Formula1:="=F" & intLigne
> par
> Selection.FormatConditions.Modify type:=xlCellValue,


Operator:=xlGreater,
> Formula1:="=F" & intLigne
> ?
> --
> Cordialement,
>
> Gilbert
>
>
> "Gaya" a écrit dans le message de
> news:
> > Bonjour a vous tous,
> >
> > Sous access 2003, je transfers en vb des enregistrements dans un


fichier
> > excel et j'ai une forme conditonnelle a appliquer .
> > Lorsque j'exécute la première fois tout est ok mais si je réexécute


une
> > secondes fois, j'obtiens l'erreur 91.
> >
> > Pour régler je dois fermer la BD et repartir. encore la je pense


seulement
> > qu'une fois et la seconde fois ça ne marche pas.
> >
> > Je plante à la ligne :
> > Selection.FormatConditions.Delete
> >
> > Voici mon code :
> >
> >
> > Private Sub cmdGenerateExcelFile_Click()
> > On Error GoTo GestionErreur
> > Dim db As Database
> > Dim rstSousProjets As Recordset
> > Dim strsql As String
> > Dim strSheetName As String
> > Dim strfiltre, intColonne As String
> > Dim flgExcelOuvert As Boolean
> > Dim flgWbkOuvert As Boolean
> >
> > Dim intFeuil As Integer, strTemplate As String
> > Dim countrecord, intLigne
> >
> > DoCmd.Hourglass True
> >
> > If Me.cboProduit <> "" And Not IsNull(Me.cboProduit) Then
> > strfiltre = "Produit = '" & Replace(Me.cboProduit, "'", "''")


&
> "'"
> > End If
> >
> > If Me.cboAnneeModele <> "" And Not IsNull(Me.cboAnneeModele) Then
> > If strfiltre <> "" Then
> > strfiltre = strfiltre & " AND "
> > End If
> > strfiltre = strfiltre & "MY = " & Me.cboAnneeModele
> > End If
> >
> > If Me.modProjet <> "" And Not IsNull(Me.modProjet) Then
> > If strfiltre <> "" Then
> > strfiltre = strfiltre & " AND "
> > End If
> > strfiltre = strfiltre & "Titre = '" & Replace(Me.modProjet,


"'",
> > "''") & "'"
> > End If
> >
> > If Not IsNull(Me.mdStatusProjet) And Me.mdStatusProjet <> "" Then
> > If Me.mdStatusProjet = "Reçue" Then
> > strfiltre = strfiltre & " AND [Date reçue] is not null"
> > Else
> > strfiltre = strfiltre & " AND [Date reçue] is null"
> > End If
> > End If
> >
> > If Me.ModTerme.Column(1) <> "" And Not


IsNull(Me.ModTerme.Column(1))
> Then
> > If strfiltre <> "" Then
> > strfiltre = strfiltre & " AND "
> > End If
> > strfiltre = strfiltre & "[Lt(1) - CT(2)] = " &
> Me.ModTerme.Column(1)
> > End If
> >
> > If strfiltre <> "" Then
> > strfiltre = "WHERE " & strfiltre
> > End If
> >
> >


'************************************************************************
> > ' Changer la cible selon où est placé le fichier template
> >


'************************************************************************
> > strTemplate = "C:ProjetsGestion de ProjetApproval.xls"
> >
> > Set db = CurrentDb()
> > Dim rstProjets As Recordset
> > Set rstProjets = db.OpenRecordset("SELECT [Projet


Principal].Titre "
> & _
> > "FROM ([Projet Principal] LEFT


JOIN
> > [Type pub tech] ON [Projet Principal].FkTypePubTech = [Type pub


tech].[No
> > type pub tech]) INNER JOIN ([Liste employé] RIGHT JOIN (([Sous-projet]
> LEFT
> > JOIN TbSousTypesPubTech ON [Sous-projet].FkSousTypePubTech > > > TbSousTypesPubTech.PkSousTypePubTech) LEFT JOIN [suivi date] ON
> > [Sous-projet].[No S-projet] = [suivi date].[s-projet]) ON [Liste
> employé].[No
> > employé] = [Sous-projet].[Resp Rédaction]) ON [Projet Principal].[No
> Projet
> > principal] = [Sous-projet].[No projet principal] " & _
> > strfiltre & _
> > " GROUP BY [Projet


Principal].Titre
> "
> > & _
> > "ORDER BY [Projet
> Principal].Titre;")
> >
> > If rstProjets.EOF Then
> > MsgBox ("Aucun résultat disponible pour votre sélection")
> > Else
> >
> > Dim XL As New Excel.Application
> > Dim wbk As Excel.Workbook
> >
> > flgExcelOuvert = True
> >
> > XL.Visible = True
> >
> > Set wbk = XL.Workbooks.Add(strTemplate)
> > flgWbkOuvert = True
> >
> > intFeuil = 1
> > rstProjets.MoveFirst
> >
> > strSheetName = Left$(rstProjets("Titre"), 31)
> > strSheetName = Replace([strSheetName], "/", " ")
> > strSheetName = Replace([strSheetName], "*", " ")
> > strSheetName = Replace([strSheetName], "", " ")
> > strSheetName = Replace([strSheetName], "?", " ")
> > wbk.Sheets(intFeuil).name = strSheetName
> > wbk.Sheets(intFeuil).Range("A2") = rstProjets("Titre")
> >
> > rstProjets.MoveNext
> > While Not rstProjets.EOF
> > wbk.Sheets(1).Copy After:=wbk.Sheets(intFeuil)
> > intFeuil = intFeuil + 1
> > wbk.Sheets(intFeuil).Range("A2") = rstProjets("Titre")
> >
> > strSheetName = Left$(rstProjets("Titre"), 31)
> > strSheetName = Replace([strSheetName], "/", " ")
> > strSheetName = Replace([strSheetName], "*", " ")
> > strSheetName = Replace([strSheetName], "", " ")
> > strSheetName = Replace([strSheetName], "?", " ")
> > wbk.Sheets(intFeuil).name = strSheetName
> >
> >
> > Set rstSousProjets = db.OpenRecordset("SELECT
> [Sous-projet].[No
> > S-projet SAV], [Sous-projet].Description, ([prenom] & ' ' & [nom]) AS
> > Responsable, [suivi date].contact, [suivi date].[date envoyé], [suivi
> > date].[Date butoir], [suivi date].[date reçue] " & _
> > "FROM ([Projet Principal] LEFT JOIN


[Type
> > pub tech] ON [Projet Principal].FkTypePubTech = [Type pub tech].[No


type
> pub
> > tech]) INNER JOIN ([Liste employé] RIGHT JOIN (([Sous-projet] LEFT


JOIN
> > TbSousTypesPubTech ON [Sous-projet].FkSousTypePubTech > > > TbSousTypesPubTech.PkSousTypePubTech) LEFT JOIN [suivi date] ON
> > [Sous-projet].[No S-projet] = [suivi date].[s-projet]) ON[Liste
> employé].[No
> > employé] = [Sous-projet].[Resp Rédaction]) ON [Projet Principal].[No
> Projet
> > principal] = [Sous-projet].[No projet principal] " & _
> > strfiltre & " AND [Projet


Principal].Titre
> > > > '" & Replace(rstProjets("Titre"), "'", "''") & "' " & _
> > "Order By [Sous-projet].[No S-projet
> SAV]")
> >
> > wbk.Sheets(strSheetName).Columns("B:B").WrapText = True
> >
> > intLigne = 6
> >
> > While Not rstSousProjets.EOF
> > With wbk.Sheets(strSheetName)
> > .Range("A" & intLigne).Value = rstSousProjets("No


S-projet
> > SAV")
> > .Range("B" & intLigne).Value > > rstSousProjets("DESCRIPTION")
> > .Range("C" & intLigne).Value rstSousProjets("Contact")
> > .Range("D" & intLigne).Value > > rstSousProjets("Responsable")
> > .Range("E" & intLigne).Value = rstSousProjets("Date
> Envoyé")
> > .Range("F" & intLigne).Value = rstSousProjets("Date
> Butoir")
> > .Range("G" & intLigne).Value = rstSousProjets("Date
> Reçue")
> >
> > .Range("E" & intLigne).NumberFormat = "yyyy/mm/dd;@"
> > .Range("F" & intLigne).NumberFormat = "yyyy/mm/dd;@"
> > .Range("G" & intLigne).NumberFormat = "yyyy/mm/dd;@"
> >
> > .Range("G" & intLigne).Select
> > Selection.FormatConditions.Delete
> > Selection.FormatConditions.Add type:=xlCellValue,
> > Operator:=xlGreater, Formula1:="=F" & intLigne
> >
> > With Selection.FormatConditions(1).Font
> > .Bold = True
> > .Italic = False
> > .ColorIndex = 3
> > End With
> > Selection.FormatConditions.Add type:=xlCellValue,
> > Operator:=xlLess, Formula1:="=F" & intLigne
> > With Selection.FormatConditions(2).Font
> > .Bold = True
> > .Italic = False
> > .ColorIndex = 10
> > End With
> > End With
> > rstSousProjets.MoveNext
> > intLigne = intLigne + 1
> > Wend
> >
> > rstSousProjets.Close
> > Set rstSousProjets = Nothing
> > rstProjets.MoveNext
> > Wend
> > 'pour finir, on rempli la feuille 1 qui nous servait de


template.
> On
> > la gardait vide pour la copier.
> > rstProjets.MoveFirst
> > Set rstSousProjets = db.OpenRecordset("SELECT


[Sous-projet].[No
> > S-projet SAV], [Sous-projet].Description, ([prenom] & ' ' & [nom]) AS
> > Responsable, [suivi date].contact, format([suivi date].[date
> > envoyé],'yyyy-mm-dd'), format([suivi date].[Date


butoir],'yyyy-mm-dd'),
> > format([suivi date].[date reçue],'yyyy-mm-dd') " & _
> > "FROM ([Projet Principal] LEFT JOIN
> [Type
> > pub tech] ON [Projet Principal].FkTypePubTech = [Type pub tech].[No


type
> pub
> > tech]) INNER JOIN ([Liste employé] RIGHT JOIN (([Sous-projet] LEFT


JOIN
> > TbSousTypesPubTech ON [Sous-projet].FkSousTypePubTech > > > TbSousTypesPubTech.PkSousTypePubTech) LEFT JOIN [suivi date] ON
> > [Sous-projet].[No S-projet] = [suivi date].[s-projet]) ON[Liste
> employé].[No
> > employé] = [Sous-projet].[Resp Rédaction]) ON [Projet Principal].[No
> Projet
> > principal] = [Sous-projet].[No projet principal] " & _
> > strfiltre & " AND [Projet
> > Principal].Titre = '" & Replace(rstProjets("Titre"), "'", "''") & "' "


& _
> > "Order By [Sous-projet].[No S-projet
> SAV]")
> > wbk.Sheets(1).Range("A6").CopyFromRecordset rstSousProjets
> > wbk.Sheets(1).Columns("B:B").WrapText = True
> > wbk.Sheets(1).Select
> > wbk.Sheets(1).Cells(1, 1).Select
> >
> > XL.Visible = True
> >
> > Set XL = Nothing
> > rstProjets.Close
> > Set rstProjets = Nothing
> > Set db = Nothing
> > Set wbk = Nothing
> >
> > End If
> >
> > DoCmd.Hourglass False
> > Exit Sub
> > GestionErreur:
> > DoCmd.Hourglass False
> > If flgWbkOuvert = True Then
> > wbk.Close False
> > Set wbk = Nothing
> > End If
> > If flgExcelOuvert = True Then
> > XL.Quit
> > Set XL = Nothing
> > End If
> > If Err.Number <> 2501 Then
> > MsgBox Err.Number & " " & Err.Description
> > Else
> > MsgBox "Il n'y a pas de données pour les paramètres


demandés.",
> > vbInformation
> > End If
> >
> > End Sub
> >
> >
> > merci de m'aider car ça fair des heures que je piétine.
> >
> > cordialement
> >
>
>
>


Avatar
Gaya
Oui c'est ce que j'ai fait et je suivais le fichier Excel du même coup.

Le pas à pas m'a toujours indiqué l'erreur au 2è passage Sur la commande du
delete .

Je continue toujours de chercher.

Merci Gilbert

"Gilbert" a écrit :


Tu dis que l'erreur se produit à la 2° exécution de la procédure. La
commande Selection.FormatConditions.Delete étant dans une boucle, as-tu
regardé à quel moment se produit l'erreur? Dès le premier passage? lors du
dernier? au milieu? Ce peut être un indice.

Il te faudrait peut-être essayer d'exécuter en pas à pas en contrôlant au
fur et à mesure ton fichier Excel.

--
Cordialement,

Gilbert


"Gaya" a écrit dans le message de
news:
> Bonsoir gilbert,
>
> Je viens d'essayer ta suggestion et malheureusement j'ai maintenant
l'erreur:
>
> 438 propriété ou méthode non géré par l'objet.
>
>
>
> "Gilbert" a écrit :
>
> > Bonjour,
> >
> > As-tu essayé de remplacer
> > Selection.FormatConditions.Delete
> > Selection.FormatConditions.Add type:=xlCellValue, Operator:=xlGreater,
> > Formula1:="=F" & intLigne
> > par
> > Selection.FormatConditions.Modify type:=xlCellValue,
Operator:=xlGreater,
> > Formula1:="=F" & intLigne
> > ?
> > --
> > Cordialement,
> >
> > Gilbert
> >
> >
> > "Gaya" a écrit dans le message de
> > news:
> > > Bonjour a vous tous,
> > >
> > > Sous access 2003, je transfers en vb des enregistrements dans un
fichier
> > > excel et j'ai une forme conditonnelle a appliquer .
> > > Lorsque j'exécute la première fois tout est ok mais si je réexécute
une
> > > secondes fois, j'obtiens l'erreur 91.
> > >
> > > Pour régler je dois fermer la BD et repartir. encore la je pense
seulement
> > > qu'une fois et la seconde fois ça ne marche pas.
> > >
> > > Je plante à la ligne :
> > > Selection.FormatConditions.Delete
> > >
> > > Voici mon code :
> > >
> > >
> > > Private Sub cmdGenerateExcelFile_Click()
> > > On Error GoTo GestionErreur
> > > Dim db As Database
> > > Dim rstSousProjets As Recordset
> > > Dim strsql As String
> > > Dim strSheetName As String
> > > Dim strfiltre, intColonne As String
> > > Dim flgExcelOuvert As Boolean
> > > Dim flgWbkOuvert As Boolean
> > >
> > > Dim intFeuil As Integer, strTemplate As String
> > > Dim countrecord, intLigne
> > >
> > > DoCmd.Hourglass True
> > >
> > > If Me.cboProduit <> "" And Not IsNull(Me.cboProduit) Then
> > > strfiltre = "Produit = '" & Replace(Me.cboProduit, "'", "''")
&
> > "'"
> > > End If
> > >
> > > If Me.cboAnneeModele <> "" And Not IsNull(Me.cboAnneeModele) Then
> > > If strfiltre <> "" Then
> > > strfiltre = strfiltre & " AND "
> > > End If
> > > strfiltre = strfiltre & "MY = " & Me.cboAnneeModele
> > > End If
> > >
> > > If Me.modProjet <> "" And Not IsNull(Me.modProjet) Then
> > > If strfiltre <> "" Then
> > > strfiltre = strfiltre & " AND "
> > > End If
> > > strfiltre = strfiltre & "Titre = '" & Replace(Me.modProjet,
"'",
> > > "''") & "'"
> > > End If
> > >
> > > If Not IsNull(Me.mdStatusProjet) And Me.mdStatusProjet <> "" Then
> > > If Me.mdStatusProjet = "Reçue" Then
> > > strfiltre = strfiltre & " AND [Date reçue] is not null"
> > > Else
> > > strfiltre = strfiltre & " AND [Date reçue] is null"
> > > End If
> > > End If
> > >
> > > If Me.ModTerme.Column(1) <> "" And Not
IsNull(Me.ModTerme.Column(1))
> > Then
> > > If strfiltre <> "" Then
> > > strfiltre = strfiltre & " AND "
> > > End If
> > > strfiltre = strfiltre & "[Lt(1) - CT(2)] = " &
> > Me.ModTerme.Column(1)
> > > End If
> > >
> > > If strfiltre <> "" Then
> > > strfiltre = "WHERE " & strfiltre
> > > End If
> > >
> > >
'************************************************************************
> > > ' Changer la cible selon où est placé le fichier template
> > >
'************************************************************************
> > > strTemplate = "C:ProjetsGestion de ProjetApproval.xls"
> > >
> > > Set db = CurrentDb()
> > > Dim rstProjets As Recordset
> > > Set rstProjets = db.OpenRecordset("SELECT [Projet
Principal].Titre "
> > & _
> > > "FROM ([Projet Principal] LEFT
JOIN
> > > [Type pub tech] ON [Projet Principal].FkTypePubTech = [Type pub
tech].[No
> > > type pub tech]) INNER JOIN ([Liste employé] RIGHT JOIN (([Sous-projet]
> > LEFT
> > > JOIN TbSousTypesPubTech ON [Sous-projet].FkSousTypePubTech > > > > TbSousTypesPubTech.PkSousTypePubTech) LEFT JOIN [suivi date] ON
> > > [Sous-projet].[No S-projet] = [suivi date].[s-projet]) ON [Liste
> > employé].[No
> > > employé] = [Sous-projet].[Resp Rédaction]) ON [Projet Principal].[No
> > Projet
> > > principal] = [Sous-projet].[No projet principal] " & _
> > > strfiltre & _
> > > " GROUP BY [Projet
Principal].Titre
> > "
> > > & _
> > > "ORDER BY [Projet
> > Principal].Titre;")
> > >
> > > If rstProjets.EOF Then
> > > MsgBox ("Aucun résultat disponible pour votre sélection")
> > > Else
> > >
> > > Dim XL As New Excel.Application
> > > Dim wbk As Excel.Workbook
> > >
> > > flgExcelOuvert = True
> > >
> > > XL.Visible = True
> > >
> > > Set wbk = XL.Workbooks.Add(strTemplate)
> > > flgWbkOuvert = True
> > >
> > > intFeuil = 1
> > > rstProjets.MoveFirst
> > >
> > > strSheetName = Left$(rstProjets("Titre"), 31)
> > > strSheetName = Replace([strSheetName], "/", " ")
> > > strSheetName = Replace([strSheetName], "*", " ")
> > > strSheetName = Replace([strSheetName], "", " ")
> > > strSheetName = Replace([strSheetName], "?", " ")
> > > wbk.Sheets(intFeuil).name = strSheetName
> > > wbk.Sheets(intFeuil).Range("A2") = rstProjets("Titre")
> > >
> > > rstProjets.MoveNext
> > > While Not rstProjets.EOF
> > > wbk.Sheets(1).Copy After:=wbk.Sheets(intFeuil)
> > > intFeuil = intFeuil + 1
> > > wbk.Sheets(intFeuil).Range("A2") = rstProjets("Titre")
> > >
> > > strSheetName = Left$(rstProjets("Titre"), 31)
> > > strSheetName = Replace([strSheetName], "/", " ")
> > > strSheetName = Replace([strSheetName], "*", " ")
> > > strSheetName = Replace([strSheetName], "", " ")
> > > strSheetName = Replace([strSheetName], "?", " ")
> > > wbk.Sheets(intFeuil).name = strSheetName
> > >
> > >
> > > Set rstSousProjets = db.OpenRecordset("SELECT
> > [Sous-projet].[No
> > > S-projet SAV], [Sous-projet].Description, ([prenom] & ' ' & [nom]) AS
> > > Responsable, [suivi date].contact, [suivi date].[date envoyé], [suivi
> > > date].[Date butoir], [suivi date].[date reçue] " & _
> > > "FROM ([Projet Principal] LEFT JOIN
[Type
> > > pub tech] ON [Projet Principal].FkTypePubTech = [Type pub tech].[No
type
> > pub
> > > tech]) INNER JOIN ([Liste employé] RIGHT JOIN (([Sous-projet] LEFT
JOIN
> > > TbSousTypesPubTech ON [Sous-projet].FkSousTypePubTech > > > > TbSousTypesPubTech.PkSousTypePubTech) LEFT JOIN [suivi date] ON
> > > [Sous-projet].[No S-projet] = [suivi date].[s-projet]) ON[Liste
> > employé].[No
> > > employé] = [Sous-projet].[Resp Rédaction]) ON [Projet Principal].[No
> > Projet
> > > principal] = [Sous-projet].[No projet principal] " & _
> > > strfiltre & " AND [Projet
Principal].Titre
> > > > > > '" & Replace(rstProjets("Titre"), "'", "''") & "' " & _
> > > "Order By [Sous-projet].[No S-projet
> > SAV]")
> > >
> > > wbk.Sheets(strSheetName).Columns("B:B").WrapText = True
> > >
> > > intLigne = 6
> > >
> > > While Not rstSousProjets.EOF
> > > With wbk.Sheets(strSheetName)
> > > .Range("A" & intLigne).Value = rstSousProjets("No
S-projet
> > > SAV")
> > > .Range("B" & intLigne).Value > > > rstSousProjets("DESCRIPTION")
> > > .Range("C" & intLigne).Value > rstSousProjets("Contact")
> > > .Range("D" & intLigne).Value > > > rstSousProjets("Responsable")
> > > .Range("E" & intLigne).Value = rstSousProjets("Date
> > Envoyé")
> > > .Range("F" & intLigne).Value = rstSousProjets("Date
> > Butoir")
> > > .Range("G" & intLigne).Value = rstSousProjets("Date
> > Reçue")
> > >
> > > .Range("E" & intLigne).NumberFormat = "yyyy/mm/dd;@"
> > > .Range("F" & intLigne).NumberFormat = "yyyy/mm/dd;@"
> > > .Range("G" & intLigne).NumberFormat = "yyyy/mm/dd;@"
> > >
> > > .Range("G" & intLigne).Select
> > > Selection.FormatConditions.Delete
> > > Selection.FormatConditions.Add type:=xlCellValue,
> > > Operator:=xlGreater, Formula1:="=F" & intLigne
> > >
> > > With Selection.FormatConditions(1).Font
> > > .Bold = True
> > > .Italic = False
> > > .ColorIndex = 3
> > > End With
> > > Selection.FormatConditions.Add type:=xlCellValue,
> > > Operator:=xlLess, Formula1:="=F" & intLigne
> > > With Selection.FormatConditions(2).Font
> > > .Bold = True
> > > .Italic = False
> > > .ColorIndex = 10
> > > End With
> > > End With
> > > rstSousProjets.MoveNext
> > > intLigne = intLigne + 1
> > > Wend
> > >
> > > rstSousProjets.Close
> > > Set rstSousProjets = Nothing
> > > rstProjets.MoveNext
> > > Wend
> > > 'pour finir, on rempli la feuille 1 qui nous servait de
template.
> > On
> > > la gardait vide pour la copier.
> > > rstProjets.MoveFirst
> > > Set rstSousProjets = db.OpenRecordset("SELECT
[Sous-projet].[No
> > > S-projet SAV], [Sous-projet].Description, ([prenom] & ' ' & [nom]) AS
> > > Responsable, [suivi date].contact, format([suivi date].[date
> > > envoyé],'yyyy-mm-dd'), format([suivi date].[Date
butoir],'yyyy-mm-dd'),
> > > format([suivi date].[date reçue],'yyyy-mm-dd') " & _
> > > "FROM ([Projet Principal] LEFT JOIN
> > [Type
> > > pub tech] ON [Projet Principal].FkTypePubTech = [Type pub tech].[No
type
> > pub
> > > tech]) INNER JOIN ([Liste employé] RIGHT JOIN (([Sous-projet] LEFT
JOIN
> > > TbSousTypesPubTech ON [Sous-projet].FkSousTypePubTech > > > > TbSousTypesPubTech.PkSousTypePubTech) LEFT JOIN [suivi date] ON
> > > [Sous-projet].[No S-projet] = [suivi date].[s-projet]) ON[Liste
> > employé].[No
> > > employé] = [Sous-projet].[Resp Rédaction]) ON [Projet Principal].[No
> > Projet
> > > principal] = [Sous-projet].[No projet principal] " & _