'### Constante à adapter ###
Const FEUILLE_SOURCE As String = "LOT 1"
'###########################
Sub PMO_ExportWord()
Dim S As Worksheet
Dim DEST As Worksheet
Dim SH As Shape
Set S = Sheets(FEUILLE_SOURCE)
Application.ScreenUpdating = False
S.Select
Selection.SpecialCells(xlCellTypeVisible).Copy
Set DEST = Sheets.Add(after:=Sheets(S.Index))
DEST.Paste
Application.CutCopyMode = False
Selection.ClearOutline
DEST.[a1].Select
For Each SH In DEST.Shapes
SH.Delete
Next SH
Call MakeDoc
Erreur:
Application.ScreenUpdating = True
If Err <> 0 Then MsgBox "Erreur " & Err.Number & _
vbCrLf & Err.Description
End Sub
Sub MakeDoc(Optional dummy As Byte)
Dim var
Dim g&
Dim i&
Dim j&
Dim nbChar&
Dim A$
Dim B$
Dim X
Dim Y
Dim WA As Object 'Word.Application
Dim DOC As Object 'Word.Document
On Error GoTo Erreur
X = vbCrLf
Y = Chr(11)
var = ActiveSheet.Range("a1:e" & ActiveSheet.[e65536].End(xlUp).Row & "")
Set WA = CreateObject("Word.application")
Set DOC = WA.Documents.Add
With DOC.PageSetup
.TopMargin = WA.CentimetersToPoints(0.75)
.BottomMargin = WA.CentimetersToPoints(1.75)
.LeftMargin = WA.CentimetersToPoints(0.7)
.RightMargin = WA.CentimetersToPoints(1)
End With
For i& = 6 To UBound(var, 1)
For j& = 1 To UBound(var, 2)
B$ = var(i&, j&)
If InStr(1, B$, Chr(10)) > 0 Then
B$ = Replace(B$, Chr(10), Y)
var(i&, j&) = B$
End If
Next j&
Next i&
For i& = 6 To UBound(var, 1)
B$ = ""
For j& = 1 To 3
B$ = B$ & var(i&, j&)
Next j&
nbChar& = Len(B$)
Select Case nbChar&
Case 1
A$ = X & Y & "- CHAPITRE " & var(i&, 1) & " -" & Y & Y & _
var(i&, 5) & Y
WA.Selection.typetext A$
DOC.ActiveWindow.Selection.TypeParagraph
With DOC.Paragraphs(DOC.Paragraphs.Count - 1).Range
With .ParagraphFormat
.LeftIndent = WA.CentimetersToPoints(5.5)
.RightIndent = WA.CentimetersToPoints(4.27)
.Alignment = 1 'wdAlignParagraphCenter
For g& = -4 To -1
With .Borders(g&)
.LineStyle = 7 'wdLineStyleDouble
.LineWidth = 4 'wdLineWidth050pt
End With
Next g&
End With
End With
A$ = ""
Case 2
A$ = X & var(i&, 1) & "." & var(i&, 2) & " - " & var(i&, 5)
WA.Selection.typetext A$
DOC.ActiveWindow.Selection.TypeParagraph
With DOC.Paragraphs(DOC.Paragraphs.Count - 1).Range
With .ParagraphFormat
.LeftIndent = WA.CentimetersToPoints(2)
.RightIndent = WA.CentimetersToPoints(0.5)
End With
.Font.Bold = True
End With
A$ = ""
Case 3
A$ = var(i&, 1) & "." & var(i&, 2) & "." & var(i&, 3) & ". " & _
var(i&, 5)
DOC.ActiveWindow.Selection.TypeParagraph
WA.Selection.typetext A$
With DOC.Paragraphs(DOC.Paragraphs.Count).Range
With .ParagraphFormat
.LeftIndent = WA.CentimetersToPoints(2)
.RightIndent = WA.CentimetersToPoints(0.5)
End With
.Font.Bold = True
End With
DOC.ActiveWindow.Selection.TypeParagraph
A$ = ""
Case Else
If var(i&, 5) <> "" Then _
A$ = var(i&, 5) & Y & Y
WA.Selection.typetext A$
With DOC.Paragraphs(DOC.Paragraphs.Count).Range
.Font.Bold = False
End With
DOC.ActiveWindow.Selection.TypeParagraph
A$ = ""
End Select
Next i&
DOC.ActiveWindow.Selection.WholeStory
Selection.Font.Name = "Arial"
DOC.Range(1, 1).Select
WA.Visible = True
Exit Sub
Erreur:
If Err <> 0 Then MsgBox "Erreur " & Err.Number & _
vbCrLf & Err.Description & vbCrLf & "Procédure MakeDoc"
End Sub