Bonjour,
apres trois jours á me casser la tete, je tente de vous soumettre une question. J´ai trouver un projet excellent sur un forum (peut etre ici je ne sais plus) qui prend le contenu des cellules d´une ligne pour les mettre á la place de signets dans un fichier créé á partir d´un fichier template. Les signets restent sur les fichiers créés ce qui est aussi excellent.
Le seul soucis c´est que je souhaiterai que la mise en forme á l´intérieur de la cellule soit aussi reproduite. Exemple pour "je mange du pain", je souhaiterais que cela soit bien reproduit avec seulement mange en gras.
voici le code :
Peut etre que la solution est toute bete, ou pas...
voici les fichiers (seule la fonction création fichier m´intéresse)
apres trois jours á me casser la tete, je tente de vous soumettre une question. J´ai trouver un projet excellent sur un forum (peut etre ici je ne sais plus) qui prend le contenu des cellules d´une ligne pour les mettre á la place de signets dans un fichier créé á partir d´un fichier template. Les signets restent sur les fichiers créés ce qui est aussi excellent.
Le seul soucis c´est que je souhaiterai que la mise en forme á l´intérieur de la cellule soit aussi reproduite. Exemple pour "je mange du pain", je souhaiterais que cela soit bien reproduit avec seulement mange en gras.
voici le code :
VB:
Option Explicit
Sub CréationFicheBase()
'nécéssite d'activer la référence Microsoft Word xx.x Object Library
Dim WordApp As Word.Application, WordDoc As Word.Document
Dim i&, j&, pos&, NomDoc$, s As Object
Application.ScreenUpdating = 0
Set WordApp = CreateObject("word.application")
On Error Resume Next
For j = 3 To [A65536].End(xlUp).Row
NomDoc = ThisWorkbook.Path & "\" & Cells(j, 1) & ".doc"
Set WordDoc = WordApp.Documents.Open(ThisWorkbook.Path & "\" & "Template.doc") 'A Modifier
WordDoc.SaveAs2 NomDoc
For i = 1 To 23
Set s = WordDoc.Bookmarks("Signet" & i)
If s Is Nothing Then GoTo Suite
WordDoc.Activate
s.Select
WordApp.Options.ReplaceSelection = True
If Cells(j, i) <> "" Then
WordApp.Selection.TypeText Cells(j, i)
pos = WordApp.Selection.Range.End
Set s = WordDoc.Range(pos - Len(Cells(j, i)), pos)
Else
WordApp.Selection.TypeText " "
pos = WordApp.Selection.Range.End
Set s = WordDoc.Range(pos - 1, pos)
End If
WordDoc.Bookmarks.Add "Signet" & i, s
On Error GoTo 0
Suite:
Next i
WordDoc.Close True
Next j
WordApp.Quit
Beep
Application.ScreenUpdating = -1
End SubPeut etre que la solution est toute bete, ou pas...
voici les fichiers (seule la fonction création fichier m´intéresse)
