<script type="VBA">
<!--
Option Explicit
Dim paraWord As Word.Paragraph
Sub essai()
'trie les feuilles par ordre croissant
Dim i As Integer, J As Integer, x As Integer
Application.ScreenUpdating = False
For i = 1 To Sheets.Count 'pour débuter le tri à la feuille x remplacer For I = 1 pat For I = x
For J = 1 To i - 1 'pour débuter le tri à la feuille x remplacer For J = 1 par For J = x
If UCase(Sheets(i).Name) < UCase(Sheets(J).Name) Then 'pour tri décroissant remplacer < par >
Sheets(i).Move Before:=Sheets(J)
Exit For
End If
Next J
Next i
'Ouverture de Word
'necesite d'activer la reference Microsoft Word xx.x Object Library
'depuis le menu Outils > Références...
Dim appWrd As Word.Application
Dim docWord As Word.Document
Dim sPath As String
Dim Fichier As String
Dim nbrtbl As Integer
'Ouverture du Template Word=======================================================================
sPath = ThisWorkbook.Path & "\" 'tous les documents sont dans ce répertoire
Fichier = sPath & "Template-preco-Pneu-NTN-SNR2.dotx" 'A adapter
Set appWrd = CreateObject("Word.Application") 'creation session Word
appWrd.Visible = True 'pour que word soit apparent
Set docWord = appWrd.Documents.Add(Template:=Fichier) 'créé un nouveau fichier word à partir du modèle
'Positionnement pour la copie des feuilles EXCEL=======================================================
docWord.Bookmarks("Signet" & 1).Select
'Procedure de copie des feuilles EXCEL============================================================
Dim s As Byte 's comme Signet
For x = 1 To Sheets.Count
Sheets(x).Select
Sheets(x).Cells.Copy
Dim Titre As String
Titre = Sheets(x).Name
s = x 'N°des signets=N°des feuilles
docWord.Bookmarks.Add ("signet" & s)
docWord.Bookmarks("Signet" & s).Range.InsertParagraphAfter
'docWord.Bookmarks("signet" & s).Select
'docWord.Bookmarks("Signet" & s).Range.PasteSpecial 'DataType:=7, Placement:=wdInLine, DisplayAsIcon:=False
'docWord.Bookmarks("signet" & s).Select
appWrd.Selection.Range.Style = "Titre 1"
appWrd.Selection.TypeText Text:=("FAMILLE : " & " " & Titre & Chr(10))
'appWrd.Selection.HomeKey
'docWord.Tables(s).Range.PasteSpecial
'appWrd.Selection.InsertBefore "" 'Text:=("FAMILLE : " & " " & Titre)
'docWord.Tables(s).Range.PasteSpecial 'DataType:=7, Placement:=wdInLine, DisplayAsIcon:=False
'appWrd.Selection.Range.PasteSpecial DataType:=7, Placement:=wdInLine, DisplayAsIcon:=False
'docWord.Bookmarks("Signet" & s).Range.InsertBreak 'Text:=("FAMILLE : " & " " & Titre)
'appWrd.Selection.Range.PasteSpecial 'DataType:=7, Placement:=wdInLine, DisplayAsIcon:=False
'docWord.Bookmarks("Signet" & s).Range.InsertParagraph 'DataType:=7, Placement:=wdInLine, DisplayAsIcon:=False
'docWord.Bookmarks("Signet" & s).Range.Collapse Direction:=wdCollapseEnd
docWord.Bookmarks("Signet" & s).Range.PasteSpecial
'docWord.Bookmarks("Signet" & s).Range.InsertParagraphAfter
'docWord.Range.PasteSpecial
'======================================================================================
docWord.Tables(s).AutoFitBehavior (wdAutoFitWindow)
With docWord.Tables(s).Range '.Font
.Font.Name = "Arial"
.Font.Size = 6
If x > 1 Then
.ParagraphFormat.Alignment = wdAlignParagraphLeft
.Cells.VerticalAlignment = wdCellAlignVerticalCenter
On Error Resume Next
.Hyperlinks(1).Delete
End If
End With
If x > 1 Then
docWord.Tables(s).Borders(wdBorderLeft).LineStyle = wdLineStyleNone
docWord.Tables(s).Borders(wdBorderRight).LineStyle = wdLineStyleNone
docWord.Tables(s).Borders(wdBorderTop).LineStyle = wdLineStyleNone
docWord.Tables(s).Borders(wdBorderBottom).LineStyle = wdLineStyleNone
docWord.Tables(s).Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
docWord.Tables(s).Borders(wdBorderVertical).LineStyle = wdLineStyleNone
'docWord.Tables(x).Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
'docWord.Tables(x).Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
docWord.Tables(s).Borders.Shadow = False
End If
'======================================================================================
appWrd.Selection.InsertBreak (wdPageBreak)
'appWrd.Selection.HomeKey
Next x
Application.CutCopyMode = False
'Sheets(1).Select
'nbrtbl = docWord.Tables.Count 'compte le nombre de tableau pour pouvoir les mettres à jour
'Ajustement a la mise en page
'For x = 1 To nbrtbl
'Next x
appWrd.ActiveDocument.TablesOfContents(1).Update
appWrd.Selection.HomeKey Unit:=wdStory
Application.ScreenUpdating = True
appWrd.ActiveDocument.SaveAs2 sPath & "Preco-Pneu-NTN-SNR2.docx"
'Impression PDF=DEBUT=============================================================================
appWrd.ActivePrinter = "PDFCreator"
appWrd.PrintOut
Set appWrd = Nothing
docWord.Close
Set appWrd = GetObject(, "Word.Application")
'If appWrd Is Nothing Then
'MsgBox "Word est fermé"
'Else
'MsgBox "Word est ouvert"
appWrd.Quit 'fermeture application Word
'End If
'appWrd.Quit (wdDoNotSaveChanges)
Kill sPath & "Preco-Pneu-NTN-SNR2.docx"
Dim OldName, NewName
Dim jour As String
jour = Format$(Date, "dd_mm_yyyy")
OldName = sPath & "Preco-Pneu-NTN-SNR2.pdf"
NewName = sPath & "Preco-Pneu-NTN-SNR-" & jour & ".pdf"
MsgBox NewName, vbInformation
Name OldName As NewName ' Déplace et renomme le fichier.
MsgBox "Traitement réalisé", vbInformation
'Impression PDF=FIN=============================================================================
End Sub
;
//-->
</script>
