Bonjour à tous,
J'ai besoin d'une grande aide pour m'aider à résoudre une problématique. Merci beaucoup par avance!
En effet, ci-après une macro qui est sur un de mes fichiers word et que je dois modifier.
Je souhaite que cette macro s'applique pour un fichier excel nommé 2X8EMEM.xls en lieu et place des documents nommés "2x8 EMEM.doc", "2x8 Prod.doc"
Voici la macro, donc selon-vous que dois-je modifier pour que cela fonctionne ?
Option Explicit
Public Const motdepasse = "007"
Public Const titre As String = "Compte Rendu Journalier"
Public Const cr As String = "Cr_du_Jour.doc"
Public Const repCRduJour As String = "Cr_du_Jour"
Public Const repRQ As String = "Bilan quotidien"
Public Const racineRQ As String = "RQ"
Public Const repModel As String = "Modeles"
Public Const modelRQ As String = "Modele_RQ.doc"
Public Const repBilanQuot As String = "Bilan Quotidien"
Public Const bilanQuot As String = "Rapport Quotidien.xlsm"
Public Const bd As String = "BDD" ' Feuille Excel base de donnée
Public chemin As String
Sub CrDuJour()
Dim fichiers As Variant
Dim cr As String, pathSep As String
Dim cheminCRduJour As String
Dim void As Variant
pathSep = Application.PathSeparator
chemin = ThisDocument.Path
cheminCRduJour = constructionChemin(repCRduJour)
fichiers = Array("Management.doc", "2x8 EMEM.doc", "2x8 Prod.doc", "5x8 Production.doc") ',"Soutien Exploitation.doc")
cr = ThisDocument.ActiveWindow.Caption
'Supprime tout
Selection.WholeStory
Selection.Delete
'Force la mise en page du document
With ActiveDocument.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientLandscape 'Portrait
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
End With
'Passage en paysage
' With ActiveDocument.PageSetup
' .Orientation = wdOrientLandscape
' End With
'Charge le premier document
void = OuvreEtCopy(cheminCRduJour & pathSep & fichiers(0), cr)
'Cette mise à jour est effectuée directement dans le compte rendu Management.doc
' void = MaJN3S(ThisDocument, cheminCRduJour & pathSep & suivi_N3S)
'Fin de modif
Selection.InsertBreak Type:=wdSectionBreakNextPage
Selection.MoveRight Unit:=wdCharacter, Count:=1
'Charge le Rapport Quotidien
'Met à jour le rapport quotidien
void = MaJRQdoc(cr)
'Passage en portrait
With Selection.PageSetup
.Orientation = wdOrientPortrait
End With
' void = OuvreEtCopy(constructionRQ(), cr)
Selection.InsertBreak Type:=wdSectionBreakNextPage
Selection.MoveLeft Unit:=wdCharacter, Count:=1
With Selection.PageSetup
.Orientation = wdOrientPortrait
.TopMargin = CentimetersToPoints(2)
.BottomMargin = CentimetersToPoints(2)
.LeftMargin = CentimetersToPoints(2)
.RightMargin = CentimetersToPoints(2)
.SectionStart = wdSectionNewColumn
End With
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Delete Unit:=wdCharacter, Count:=1
'Charge le document suivant
void = OuvreEtCopy(cheminCRduJour & pathSep & fichiers(1), cr)
Selection.InsertBreak Type:=wdPageBreak
'Charge le document suivant
void = OuvreEtCopy(cheminCRduJour & pathSep & fichiers(2), cr)
Selection.InsertBreak Type:=wdPageBreak
'*****Début : Retrait de la page au format paysage du Rapport 2x8 Prod
' Selection.InsertBreak Type:=wdSectionBreakNextPage
' Selection.MoveLeft Unit:=wdCharacter, Count:=1
' With Selection.PageSetup
' .Orientation = wdOrientLandscape
' .TopMargin = CentimetersToPoints(1)
' .BottomMargin = CentimetersToPoints(1)
' .LeftMargin = CentimetersToPoints(1)
' .RightMargin = CentimetersToPoints(1)
' .SectionStart = wdSectionNewColumn
' End With
' Selection.MoveRight Unit:=wdCharacter, Count:=1
' Selection.Delete Unit:=wdCharacter, Count:=1
'*****Fin : Retrait de la page au format paysage du Rapport 2x8 Prod
'Charge le dernier document
void = OuvreEtCopy(cheminCRduJour & pathSep & fichiers(3), cr)
'Suppression du rapport Soutien explotation...
' Selection.InsertBreak Type:=wdPageBreak
' void = OuvreEtCopy(cheminCRduJour & pathSep & fichiers(4), cr)
' With Selection.PageSetup
' .Orientation = wdOrientLandscape
' .TopMargin = CentimetersToPoints(1)
' .BottomMargin = CentimetersToPoints(1)
' .LeftMargin = CentimetersToPoints(0.7)
' .RightMargin = CentimetersToPoints(0.7)
' .SectionStart = wdSectionNewColumn
' End With
Selection.HomeKey Unit:=wdStory
ActiveDocument.Save
End Sub
Private Function OuvreEtCopy(fichier, w As String)
Dim WDdoc As Document
On Error GoTo Erreur
Application.ScreenUpdating = False
Set WDdoc = Documents.Open(FileName:=fichier, ConfirmConversions:=False, _
ReadOnly:=True, AddToRecentFiles:=False, PasswordDocument:="", _
PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
WritePasswordTemplate:="", Format:=wdOpenFormatAuto)
Selection.WholeStory
Selection.Copy
WDdoc.Close False
Set WDdoc = Nothing
Windows(w).Activate
Selection.Paste
GoTo Fin
Erreur:
Windows(w).Activate
Selection.Font.ColorIndex = wdRed
Selection.TypeText Text:="Le document : "
Selection.Font.Bold = wdToggle
Selection.TypeText Text:=fichier
Selection.Font.Bold = wdToggle
Selection.TypeText Text:=" n'a pas été trouvé !"
Selection.Font.ColorIndex = wdAuto
Fin:
Application.ScreenUpdating = True
End Function
Function constructionRQ()
Dim rep As String, sep As String, aa As String
Dim i As Integer, ok As Integer
rep = ThisDocument.Path
sep = Application.PathSeparator
aa = CStr(Year(Date))
For i = 1 To Len(rep)
If Mid(rep, i, 1) = sep Then
ok = ok + 1
If ok = 2 Then
constructionRQ = Left(rep, i) & repRQ & sep _
& racineRQ & aa & sep & racineRQ & Mid$(aa, 3, 2) _
& Format(Date - DateValue("01/01/" & aa), "000") & ".doc" 'normalement + 1
Exit For
End If
End If
Next
End Function
Function constructionChemin(repPlus As String, Optional niveau As Integer = -1) As String
Dim rep As String, sep As String, aa As String
Dim i As Integer
rep = ThisDocument.Path
sep = Application.PathSeparator
For i = Len(rep) To 1 Step -1
If Mid(rep, i, 1) = sep Then
niveau = niveau + 1
If niveau = 0 Then
constructionChemin = Left(rep, i) & repPlus
Exit For
End If
End If
Next
End Function
Private Function MaJRQdoc(w As String)
Dim docRQ As String
Dim dateRQ As Date
Dim XLapp As Object
Dim XLwkb As Workbook
Dim XLsheet As Worksheet
Dim XLCell As Excel.Range
Dim WDdoc As Document
Dim WDtop As Range
Dim xlFic As String
On Error GoTo Erreur
Application.ScreenUpdating = False
'Ouverture du document Rapport Quotidien (le document doit être vide)
docRQ = constructionChemin(repModel) & Application.PathSeparator & modelRQ
Set WDdoc = Documents.Open(FileName:=docRQ, ConfirmConversions:=False, _
ReadOnly:=True, AddToRecentFiles:=False, PasswordDocument:="", _
PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
WritePasswordTemplate:="", Format:=wdOpenFormatAuto)
'Ouvre la base Bilan Quotidien Excel
xlFic = constructionChemin(repBilanQuot, -2) & Application.PathSeparator & bilanQuot
Set XLapp = CreateObject("excel.application")
Set XLwkb = Workbooks.Open(xlFic, 0, True)
'La rapport quotidien est celui est celui du jour (d'aujourd'hui) - 1
dateRQ = Date - 1
'Renseigne le numéro chrono et la date dans le Rapport quotidien
frappeTexte WDdoc, "NoRQ", "N° : " & _
Format(dateRQ, "YY") & "/" & Format(dateRQ - DateSerial(Year(dateRQ), 1, 1) + 1, "000")
frappeTexte WDdoc, "DateRQ", _
"Du " & Format(dateRQ, "dd/mm/yyyy") & " 5h30 au " & _
Format(dateRQ + 1, "dd/mm/yyyy") & " 5h30"
'Ote la protection du classeur
XLwkb.Unprotect
'Affiche la feuille concernée
XLwkb.Worksheets(bd).Visible = True
XLwkb.Worksheets(bd).Activate
'Recherche de la ligne des données du jour concernée
Set XLCell = ActiveSheet.Columns("B:B").Find(What:=CLng(Date - 1), LookIn:=xlValues, _
LookAt:=xlPart)
If XLCell Is Nothing Then
MsgBox "La date " & (dateRQ) & " ne peut être trouvée dans la plage de cellule !" & Chr(13) & "Désolé !", vbApplicationModal + vbOKOnly + vbExclamation, "Export des données"
GoTo Fin
End If
'lecture des données de la base Excel et mise à jour du document
Lecture_Ecriture_BDD XLCell.Row, XLwkb.Worksheets(bd), WDdoc, "ExportWord"
'Ferme le fichier et quit Excel
XLwkb.Close False
XLapp.Quit ' Une fois terminé, utilise la méthode Quit pour fermer
Set XLwkb = Nothing
Set XLapp = Nothing ' puis libère la référence.
'Copie, Ferme et colle le Rapport quotidien dans le CR du jour
Set WDtop = WDdoc.GoTo(What:=wdGoToLine, Which:=wdGoToFirst)
WDtop.Select
Selection.WholeStory
Selection.Copy
WDdoc.Close False 'pas de sauvegarde du document Rapport Quotidien (pour le laisser Vierge)
Set WDdoc = Nothing
Windows(w).Activate
Selection.Paste
GoTo Fin
Erreur:
Windows(w).Activate
Selection.Font.ColorIndex = wdRed
Selection.TypeText Text:="La mise à jour du rapport quotidien à provoquer une erreur : "
Selection.Font.Bold = wdToggle
Selection.TypeText Text:=Err.Number
Selection.Font.Bold = wdToggle
Selection.TypeText Text:=" - "
Selection.Font.Bold = wdToggle
Selection.TypeText Text:=Err.Description
Selection.Font.Bold = wdToggle
Selection.Font.ColorIndex = wdAuto
Fin:
Application.ScreenUpdating = True
End Function
Private Function frappeTexte(doc As Document, nomSignet As String, chaine As String)
Dim signet As Range
Set signet = doc.GoTo(What:=wdGoToBookmark, Name:=nomSignet)
signet.Select
Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.TypeText Text:=chaine
Set signet = Nothing
End Function
Private Function Lecture_Ecriture_BDD(lign_bd As Integer, feuilBD As Worksheet, doc As Document, Optional mode As String = "Lecture")
Dim colon_bd As Integer
colon_bd = 3
'Activité : AD2 - Batiment A
colon_bd = TraitementBDD(7, "BatA", lign_bd, colon_bd, feuilBD, doc, mode)
'Activité : AD2 - Batiment B
colon_bd = TraitementBDD(11, "BatB", lign_bd, colon_bd, feuilBD, doc, mode)
'Activité : EDS
colon_bd = TraitementBDD(4, "EDS", lign_bd, colon_bd, feuilBD, doc, mode)
'Activité : ADT1
colon_bd = TraitementBDD(2, "ADT", lign_bd, colon_bd, feuilBD, doc, mode)
'Activité : DEDS
colon_bd = TraitementBDD(6, "DEDS", lign_bd, colon_bd, feuilBD, doc, mode)
'Activité : ECC
colon_bd = TraitementBDD(2, "ECC", lign_bd, colon_bd, feuilBD, doc, mode)
'Activité : Batiment 116
colon_bd = TraitementBDD(3, "Bat116_", lign_bd, colon_bd, feuilBD, doc, mode)
'Etat des stocks : AD2 - Batiment A
colon_bd = TraitementBDD(10, "SBatA", lign_bd, colon_bd, feuilBD, doc, mode)
'Etat des stocks : AD2 - Batiment B + (2 emem valeur Pu)
colon_bd = TraitementBDD(12, "SBatB", lign_bd, colon_bd, feuilBD, doc, mode)
'Etat des stocks : AD2 - Batiment B (2 emem valeur Pu)
'colon_bd = TraitementBDD(1, 40, 8, lign_bd, colon_bd, feuilBD, doc, mode)
'Etat des stocks : AD2 - Batiment C
colon_bd = TraitementBDD(3, "SBatC", lign_bd, colon_bd, feuilBD, doc, mode)
'Etat des stocks : EDS
colon_bd = TraitementBDD(12, "SEDS", lign_bd, colon_bd, feuilBD, doc, mode)
'Etat des stocks : ECC
colon_bd = TraitementBDD(6, "SECC", lign_bd, colon_bd, feuilBD, doc, mode)
'Etat des stocks : DEDS ECE (pleins)
colon_bd = TraitementBDD(2, "SDEDSP", lign_bd, colon_bd, feuilBD, doc, mode)
'Etat des stocks : DEDS ECE (vidés)
colon_bd = TraitementBDD(2, "SDEDSV", lign_bd, colon_bd, feuilBD, doc, mode)
'Etat des stocks : DEDS FCE
colon_bd = TraitementBDD(2, "SDEDSFCE", lign_bd, colon_bd, feuilBD, doc, mode)
End Function
Private Function TraitementBDD(nbVal As Integer, nomSignet As String, lign_bd As Integer, colon_bd As Integer, feuilBD As Worksheet, doc As Document, Optional mode As String = "Lecture") As Integer
Dim i As Integer
Select Case mode
Case "ExportWord"
For i = 1 To nbVal
frappeTexte doc, nomSignet & i, _
feuilBD.Cells(lign_bd, colon_bd).Value
colon_bd = colon_bd + 1
Next
Case Else
MsgBox mode & " inconnu !" & Chr(13) & "Désolé !", vbApplicationModal + vbCritical + vbOKOnly
End Select
TraitementBDD = colon_bd
End Function
J'ai besoin d'une grande aide pour m'aider à résoudre une problématique. Merci beaucoup par avance!
En effet, ci-après une macro qui est sur un de mes fichiers word et que je dois modifier.
Je souhaite que cette macro s'applique pour un fichier excel nommé 2X8EMEM.xls en lieu et place des documents nommés "2x8 EMEM.doc", "2x8 Prod.doc"
Voici la macro, donc selon-vous que dois-je modifier pour que cela fonctionne ?
Option Explicit
Public Const motdepasse = "007"
Public Const titre As String = "Compte Rendu Journalier"
Public Const cr As String = "Cr_du_Jour.doc"
Public Const repCRduJour As String = "Cr_du_Jour"
Public Const repRQ As String = "Bilan quotidien"
Public Const racineRQ As String = "RQ"
Public Const repModel As String = "Modeles"
Public Const modelRQ As String = "Modele_RQ.doc"
Public Const repBilanQuot As String = "Bilan Quotidien"
Public Const bilanQuot As String = "Rapport Quotidien.xlsm"
Public Const bd As String = "BDD" ' Feuille Excel base de donnée
Public chemin As String
Sub CrDuJour()
Dim fichiers As Variant
Dim cr As String, pathSep As String
Dim cheminCRduJour As String
Dim void As Variant
pathSep = Application.PathSeparator
chemin = ThisDocument.Path
cheminCRduJour = constructionChemin(repCRduJour)
fichiers = Array("Management.doc", "2x8 EMEM.doc", "2x8 Prod.doc", "5x8 Production.doc") ',"Soutien Exploitation.doc")
cr = ThisDocument.ActiveWindow.Caption
'Supprime tout
Selection.WholeStory
Selection.Delete
'Force la mise en page du document
With ActiveDocument.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientLandscape 'Portrait
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
End With
'Passage en paysage
' With ActiveDocument.PageSetup
' .Orientation = wdOrientLandscape
' End With
'Charge le premier document
void = OuvreEtCopy(cheminCRduJour & pathSep & fichiers(0), cr)
'Cette mise à jour est effectuée directement dans le compte rendu Management.doc
' void = MaJN3S(ThisDocument, cheminCRduJour & pathSep & suivi_N3S)
'Fin de modif
Selection.InsertBreak Type:=wdSectionBreakNextPage
Selection.MoveRight Unit:=wdCharacter, Count:=1
'Charge le Rapport Quotidien
'Met à jour le rapport quotidien
void = MaJRQdoc(cr)
'Passage en portrait
With Selection.PageSetup
.Orientation = wdOrientPortrait
End With
' void = OuvreEtCopy(constructionRQ(), cr)
Selection.InsertBreak Type:=wdSectionBreakNextPage
Selection.MoveLeft Unit:=wdCharacter, Count:=1
With Selection.PageSetup
.Orientation = wdOrientPortrait
.TopMargin = CentimetersToPoints(2)
.BottomMargin = CentimetersToPoints(2)
.LeftMargin = CentimetersToPoints(2)
.RightMargin = CentimetersToPoints(2)
.SectionStart = wdSectionNewColumn
End With
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Delete Unit:=wdCharacter, Count:=1
'Charge le document suivant
void = OuvreEtCopy(cheminCRduJour & pathSep & fichiers(1), cr)
Selection.InsertBreak Type:=wdPageBreak
'Charge le document suivant
void = OuvreEtCopy(cheminCRduJour & pathSep & fichiers(2), cr)
Selection.InsertBreak Type:=wdPageBreak
'*****Début : Retrait de la page au format paysage du Rapport 2x8 Prod
' Selection.InsertBreak Type:=wdSectionBreakNextPage
' Selection.MoveLeft Unit:=wdCharacter, Count:=1
' With Selection.PageSetup
' .Orientation = wdOrientLandscape
' .TopMargin = CentimetersToPoints(1)
' .BottomMargin = CentimetersToPoints(1)
' .LeftMargin = CentimetersToPoints(1)
' .RightMargin = CentimetersToPoints(1)
' .SectionStart = wdSectionNewColumn
' End With
' Selection.MoveRight Unit:=wdCharacter, Count:=1
' Selection.Delete Unit:=wdCharacter, Count:=1
'*****Fin : Retrait de la page au format paysage du Rapport 2x8 Prod
'Charge le dernier document
void = OuvreEtCopy(cheminCRduJour & pathSep & fichiers(3), cr)
'Suppression du rapport Soutien explotation...
' Selection.InsertBreak Type:=wdPageBreak
' void = OuvreEtCopy(cheminCRduJour & pathSep & fichiers(4), cr)
' With Selection.PageSetup
' .Orientation = wdOrientLandscape
' .TopMargin = CentimetersToPoints(1)
' .BottomMargin = CentimetersToPoints(1)
' .LeftMargin = CentimetersToPoints(0.7)
' .RightMargin = CentimetersToPoints(0.7)
' .SectionStart = wdSectionNewColumn
' End With
Selection.HomeKey Unit:=wdStory
ActiveDocument.Save
End Sub
Private Function OuvreEtCopy(fichier, w As String)
Dim WDdoc As Document
On Error GoTo Erreur
Application.ScreenUpdating = False
Set WDdoc = Documents.Open(FileName:=fichier, ConfirmConversions:=False, _
ReadOnly:=True, AddToRecentFiles:=False, PasswordDocument:="", _
PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
WritePasswordTemplate:="", Format:=wdOpenFormatAuto)
Selection.WholeStory
Selection.Copy
WDdoc.Close False
Set WDdoc = Nothing
Windows(w).Activate
Selection.Paste
GoTo Fin
Erreur:
Windows(w).Activate
Selection.Font.ColorIndex = wdRed
Selection.TypeText Text:="Le document : "
Selection.Font.Bold = wdToggle
Selection.TypeText Text:=fichier
Selection.Font.Bold = wdToggle
Selection.TypeText Text:=" n'a pas été trouvé !"
Selection.Font.ColorIndex = wdAuto
Fin:
Application.ScreenUpdating = True
End Function
Function constructionRQ()
Dim rep As String, sep As String, aa As String
Dim i As Integer, ok As Integer
rep = ThisDocument.Path
sep = Application.PathSeparator
aa = CStr(Year(Date))
For i = 1 To Len(rep)
If Mid(rep, i, 1) = sep Then
ok = ok + 1
If ok = 2 Then
constructionRQ = Left(rep, i) & repRQ & sep _
& racineRQ & aa & sep & racineRQ & Mid$(aa, 3, 2) _
& Format(Date - DateValue("01/01/" & aa), "000") & ".doc" 'normalement + 1
Exit For
End If
End If
Next
End Function
Function constructionChemin(repPlus As String, Optional niveau As Integer = -1) As String
Dim rep As String, sep As String, aa As String
Dim i As Integer
rep = ThisDocument.Path
sep = Application.PathSeparator
For i = Len(rep) To 1 Step -1
If Mid(rep, i, 1) = sep Then
niveau = niveau + 1
If niveau = 0 Then
constructionChemin = Left(rep, i) & repPlus
Exit For
End If
End If
Next
End Function
Private Function MaJRQdoc(w As String)
Dim docRQ As String
Dim dateRQ As Date
Dim XLapp As Object
Dim XLwkb As Workbook
Dim XLsheet As Worksheet
Dim XLCell As Excel.Range
Dim WDdoc As Document
Dim WDtop As Range
Dim xlFic As String
On Error GoTo Erreur
Application.ScreenUpdating = False
'Ouverture du document Rapport Quotidien (le document doit être vide)
docRQ = constructionChemin(repModel) & Application.PathSeparator & modelRQ
Set WDdoc = Documents.Open(FileName:=docRQ, ConfirmConversions:=False, _
ReadOnly:=True, AddToRecentFiles:=False, PasswordDocument:="", _
PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
WritePasswordTemplate:="", Format:=wdOpenFormatAuto)
'Ouvre la base Bilan Quotidien Excel
xlFic = constructionChemin(repBilanQuot, -2) & Application.PathSeparator & bilanQuot
Set XLapp = CreateObject("excel.application")
Set XLwkb = Workbooks.Open(xlFic, 0, True)
'La rapport quotidien est celui est celui du jour (d'aujourd'hui) - 1
dateRQ = Date - 1
'Renseigne le numéro chrono et la date dans le Rapport quotidien
frappeTexte WDdoc, "NoRQ", "N° : " & _
Format(dateRQ, "YY") & "/" & Format(dateRQ - DateSerial(Year(dateRQ), 1, 1) + 1, "000")
frappeTexte WDdoc, "DateRQ", _
"Du " & Format(dateRQ, "dd/mm/yyyy") & " 5h30 au " & _
Format(dateRQ + 1, "dd/mm/yyyy") & " 5h30"
'Ote la protection du classeur
XLwkb.Unprotect
'Affiche la feuille concernée
XLwkb.Worksheets(bd).Visible = True
XLwkb.Worksheets(bd).Activate
'Recherche de la ligne des données du jour concernée
Set XLCell = ActiveSheet.Columns("B:B").Find(What:=CLng(Date - 1), LookIn:=xlValues, _
LookAt:=xlPart)
If XLCell Is Nothing Then
MsgBox "La date " & (dateRQ) & " ne peut être trouvée dans la plage de cellule !" & Chr(13) & "Désolé !", vbApplicationModal + vbOKOnly + vbExclamation, "Export des données"
GoTo Fin
End If
'lecture des données de la base Excel et mise à jour du document
Lecture_Ecriture_BDD XLCell.Row, XLwkb.Worksheets(bd), WDdoc, "ExportWord"
'Ferme le fichier et quit Excel
XLwkb.Close False
XLapp.Quit ' Une fois terminé, utilise la méthode Quit pour fermer
Set XLwkb = Nothing
Set XLapp = Nothing ' puis libère la référence.
'Copie, Ferme et colle le Rapport quotidien dans le CR du jour
Set WDtop = WDdoc.GoTo(What:=wdGoToLine, Which:=wdGoToFirst)
WDtop.Select
Selection.WholeStory
Selection.Copy
WDdoc.Close False 'pas de sauvegarde du document Rapport Quotidien (pour le laisser Vierge)
Set WDdoc = Nothing
Windows(w).Activate
Selection.Paste
GoTo Fin
Erreur:
Windows(w).Activate
Selection.Font.ColorIndex = wdRed
Selection.TypeText Text:="La mise à jour du rapport quotidien à provoquer une erreur : "
Selection.Font.Bold = wdToggle
Selection.TypeText Text:=Err.Number
Selection.Font.Bold = wdToggle
Selection.TypeText Text:=" - "
Selection.Font.Bold = wdToggle
Selection.TypeText Text:=Err.Description
Selection.Font.Bold = wdToggle
Selection.Font.ColorIndex = wdAuto
Fin:
Application.ScreenUpdating = True
End Function
Private Function frappeTexte(doc As Document, nomSignet As String, chaine As String)
Dim signet As Range
Set signet = doc.GoTo(What:=wdGoToBookmark, Name:=nomSignet)
signet.Select
Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.TypeText Text:=chaine
Set signet = Nothing
End Function
Private Function Lecture_Ecriture_BDD(lign_bd As Integer, feuilBD As Worksheet, doc As Document, Optional mode As String = "Lecture")
Dim colon_bd As Integer
colon_bd = 3
'Activité : AD2 - Batiment A
colon_bd = TraitementBDD(7, "BatA", lign_bd, colon_bd, feuilBD, doc, mode)
'Activité : AD2 - Batiment B
colon_bd = TraitementBDD(11, "BatB", lign_bd, colon_bd, feuilBD, doc, mode)
'Activité : EDS
colon_bd = TraitementBDD(4, "EDS", lign_bd, colon_bd, feuilBD, doc, mode)
'Activité : ADT1
colon_bd = TraitementBDD(2, "ADT", lign_bd, colon_bd, feuilBD, doc, mode)
'Activité : DEDS
colon_bd = TraitementBDD(6, "DEDS", lign_bd, colon_bd, feuilBD, doc, mode)
'Activité : ECC
colon_bd = TraitementBDD(2, "ECC", lign_bd, colon_bd, feuilBD, doc, mode)
'Activité : Batiment 116
colon_bd = TraitementBDD(3, "Bat116_", lign_bd, colon_bd, feuilBD, doc, mode)
'Etat des stocks : AD2 - Batiment A
colon_bd = TraitementBDD(10, "SBatA", lign_bd, colon_bd, feuilBD, doc, mode)
'Etat des stocks : AD2 - Batiment B + (2 emem valeur Pu)
colon_bd = TraitementBDD(12, "SBatB", lign_bd, colon_bd, feuilBD, doc, mode)
'Etat des stocks : AD2 - Batiment B (2 emem valeur Pu)
'colon_bd = TraitementBDD(1, 40, 8, lign_bd, colon_bd, feuilBD, doc, mode)
'Etat des stocks : AD2 - Batiment C
colon_bd = TraitementBDD(3, "SBatC", lign_bd, colon_bd, feuilBD, doc, mode)
'Etat des stocks : EDS
colon_bd = TraitementBDD(12, "SEDS", lign_bd, colon_bd, feuilBD, doc, mode)
'Etat des stocks : ECC
colon_bd = TraitementBDD(6, "SECC", lign_bd, colon_bd, feuilBD, doc, mode)
'Etat des stocks : DEDS ECE (pleins)
colon_bd = TraitementBDD(2, "SDEDSP", lign_bd, colon_bd, feuilBD, doc, mode)
'Etat des stocks : DEDS ECE (vidés)
colon_bd = TraitementBDD(2, "SDEDSV", lign_bd, colon_bd, feuilBD, doc, mode)
'Etat des stocks : DEDS FCE
colon_bd = TraitementBDD(2, "SDEDSFCE", lign_bd, colon_bd, feuilBD, doc, mode)
End Function
Private Function TraitementBDD(nbVal As Integer, nomSignet As String, lign_bd As Integer, colon_bd As Integer, feuilBD As Worksheet, doc As Document, Optional mode As String = "Lecture") As Integer
Dim i As Integer
Select Case mode
Case "ExportWord"
For i = 1 To nbVal
frappeTexte doc, nomSignet & i, _
feuilBD.Cells(lign_bd, colon_bd).Value
colon_bd = colon_bd + 1
Next
Case Else
MsgBox mode & " inconnu !" & Chr(13) & "Désolé !", vbApplicationModal + vbCritical + vbOKOnly
End Select
TraitementBDD = colon_bd
End Function