formule ou macro pour prénom

[C@thy]

Bonjour le forum,

j'ai une colonne C avec le prénom usuel puis une colonne D avec tous les prénoms, je voudrais copier dans Word en mettant le prénom usuel en italique

je m'explique :

1... AZERTY... Edouard... Jules Edouard Lucas

dans Word je veux récupérer

1 AZERTY Jules Edouard Lucas

Deux possibilités : soit je balise sous Excel au préalable avec $ avant et $ après, puis macro sous word pour supprimer les $ et mettre en italique,
soit je copie directement les colonnes A B D en mettant le prénom usuel en italique, mais ceci me semble carrément infaisable.

Merci pour vos suggestions

Bises et bonne journée

C@thy

 

[pierrejean]

Re : formule ou macro pour prénom

bonjour C@thy

Une approche te permettant d'avoir en colonne E le format que tu souhaites copier dans Word

 

[C@thy]

Re : formule ou macro pour prénom

Merci PJ, je regarde ça et je te dis.

Bises

C@thy

 

[C@thy]

Re : formule ou macro pour prénom

Coucou PJ,😉

j'ai testé, ça fonctionne nickel,
mais pour récupérer l'italique dans Word, j'y suis pas encore arrivée.

Damned!

Bises

C@thy

 

[pierrejean]

Re : formule ou macro pour prénom

Re

Peux-tu preciser ce que tu souhaites dans Word
A 1ere vue un copier/coller fonctionne avec la cellule complete

 

[C@thy]

Re : formule ou macro pour prénom

Coucou PJ,

j'étais justement en train de regarder ton code, j'aime bien l'usage du instr

j'essayais de comprendre comment ça marche, mais j'ai rien comprins (patience...)

j'ai bidouillé ceci (avec des bout de bric et de broc trouvés ça et là, Merci Tatiak):

'Activer Outils Références Microsdoft Word 11.0 Object Library
Sub DicoItalique()
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim Chemin As String, NDGusse As String
Dim C As Range
Dim derligne As Integer, i As Integer
Chemin = ThisWorkbook.Path
derligne = Range("C65000").End(xlUp).Row
Set WordApp = CreateObject("Word.application")
Set WordDoc = WordApp.Documents.Add(DocumentType:=0)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' WordApp.Visible = False 'on NE voit PAS ce qui se passe dans le cocument WORD
WordApp.Visible = True 'on voit ce qui se passe dans le cocument WORD
On Error Resume Next
For i = 1 To derligne


With WordApp
NDGusse = Sheets("Feuil1").Range("C" & i).Text
For Each C In Sheets("Feuil1").Range("A" & i & ":" & Sheets("Feuil1").Range("IV" & i).End(xlToLeft).Address)
.Selection.TypeText Text:=C.Text & " " 'vbTab
.Selection.Font.Italic = msoTrue

Next C
.Selection.TypeParagraph


If Not i = derligne Then WordApp.Selection.InsertBreak Type:=wdPageBreak
End With
Next i

MsgBox "Fin traitement"
WordDoc.SaveAs Filename:=Chemin & "\Dico.doc"

' WordApp.Quit 'Pour Fermer Word
Set WordApp = Nothing
Set WordDoc = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

mais ça me met TOUT en italique

C@thy

 

[C@thy]

Re : formule ou macro pour prénom

Coucou les zamis

Quand on parle du loup... (speaking of the devil...)

Bon, je résume,

tout ce que vous avez fait, PJ, tatiak, fonctionne, mais pas comme je le souhaiterais (Ah les femmes!!!). Je récupère tout en italique, or dans l'état civil seul le prénom usuel doit être en italique

Peut-être faudrait-il mettre un $ avant et après le prénom usuel, puis ensuite une macro sous word qui prend tout ce qui est entre $ et qui le met en italique
imagine qu'on le mette entre crochets : [prenomUsuel]
ensuite on peut mettre en italique par macro sous word ce qui est entre crochets :

Sub Crochets()
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .MatchWildcards = True
        .Text = "(\[*\])"
        .Replacement.Font.Italic = True
        .Execute Replace:=wdReplaceAll
  End With
End Sub

Bises

C@thy

 

[pierrejean]

Re : formule ou macro pour prénom

Re

A tester:

Sub test()
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
 For n = 1 To Range("C65536").End(xlUp).Row
   If InStr(Range("D" & n), Range("C" & n)) <> 0 Then
     Range("E" & n) = Range("A" & n) & " " & Range("B" & n) & " " & Range("D" & n)
     x = InStr(Range("E" & n), Range("C" & n))
     y = Len(Range("C" & n)) + 1
     Range("E" & n).Characters(x, y).Font.FontStyle = "Italique"
   End If
 Next n
Range("E1:E" & Range("E65536").End(xlUp).Row).Copy
Set WordApp = CreateObject("Word.application")
Set WordDoc = WordApp.Documents.Add(DocumentType:=0)
WordApp.Visible = True
WordApp.Selection.Paste
End Sub

 

[C@thy]

Re : formule ou macro pour prénom

Re coucou,

bon, j'avance sur le truc, et je me suis rendue compte que je ne vous avais pas donné une vision globale de la chose.

Je pars du fichiet Italique2 (qui en fait s'appellera Etat Civil) dans lequel se trouve la macro ensuite je rajoute les données des 5 autres fichiers pour obtenir le document Word qui doit avoir la tête de Dico2 (qui en fait s'appellera Dico).

Alors y'a un truc que je pige pas, c'est que la macro de PJ marche bien mais en la reprenant dans ma macro j'obtiens un tableau au lieu d'une ligne pour les cellules n°+nom+info+prenoms qui comporte le prénom usuel en italique,
alors j'essaie de bidouiller sous word pour tranformer ce tableau en texte...
et je m'arrache les cheveux (heureusement, j'en ai beaucoup!)

ci-joint l'ensemble du bidule.

Bises et bon ouik à tous

C@thy

 

[pierrejean]

Re : formule ou macro pour prénom

Re

Voila pour avoir du texte

Sub test()
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
 For n = 1 To Range("C65536").End(xlUp).Row
   If InStr(Range("D" & n), Range("C" & n)) <> 0 Then
     Range("E" & n) = Range("A" & n) & " " & Range("B" & n) & " " & Range("D" & n)
     x = InStr(Range("E" & n), Range("C" & n))
     y = Len(Range("C" & n)) + 1
     Range("E" & n).Characters(x, y).Font.FontStyle = "Italique"
   End If
 Next n
Set plage = Range("E1:E" & Range("E65536").End(xlUp).Row)
plage.Copy
nbl = plage.Rows.Count
Set WordApp = CreateObject("Word.application")
Set WordDoc = WordApp.Documents.Add(DocumentType:=0)
WordApp.Visible = True
WordApp.Selection.Paste
WordApp.Selection.MoveUp Unit:=wdLine, Count:=nbl
WordApp.Selection.Rows.ConvertToText Separator:=wdSeparateByParagraphs, _
        NestedTables:=True
End Sub

Mais si tu veux aboutir a un Word tel que Dico2 on n'est pas franchement sorti de l'auberge

Ps : j'ai travaillé sur mon fichier d'origine il te faudra adapter pour Italique2

 

[C@thy]

Re : formule ou macro pour prénom

Merci PJ, je creuse dans ce sens, mais je ne peux pas faire comme ça car je n'ai pas que la colonne C à copier, j'ai aussi les autres colonnes + les 5 autres fichiers, donc je dois copier ligne par ligne et non pas toutes les lignes d'un coup.

Et comme tu dis, pour obtenir Dico2 on n'est pas rendus!!!😀😡

Bises

C@thy

 

[C@thy]

Re : formule ou macro pour prénom

OK, PJ, ça marche, j'avance et je te tiens au courant...

Bises

C@thy

 

[C@thy]

Re : formule ou macro pour prénom

Bon, alors, résultat des courses : ça marche, je colle et je transforme en texte, mais je n'arrive pas à désélectionner, donc je colle le reste à la place et non après grrrrrr

Vé p'têt' poser la question sur le forum Word, kestenpense?

C@thy



'Activer Outils Références Microsdoft Word 11.0 Object Library
Sub DicoItalique()
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim Chemin As String, NDGusse As String
Dim C As Range
Dim derligne As Integer, n As Integer
Chemin = ThisWorkbook.Path
derligne = Range("C65000").End(xlUp).Row
Set WordApp = CreateObject("Word.application")
Set WordDoc = WordApp.Documents.Add(DocumentType:=0)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' WordApp.Visible = False 'on NE voit PAS ce qui se passe dans le cocument WORD
WordApp.Visible = True 'on voit ce qui se passe dans le cocument WORD
On Error Resume Next
For n = 2 To derligne
' ...
'code pour mettre le prénom usuel en italique
' ...

Range("G" & n) = Range("B" & n) & " " & Range("C" & n) & " " & Range("D" & n) & " " & Range("F" & n)
If InStr(Range("F" & n), Range("E" & n)) <> 0 Then
x = InStr(Range("G" & n), Range("E" & n))
y = Len(Range("E" & n)) + 1
Range("G" & n).Characters(x, y).Font.FontStyle = "Italique"
End If
' ...
'code pour copier les données dans Word
' ...
NDGusse = Range("C" & n).Text
With WordApp
.Visible = True

End With
' Set plage = Range("G" & n & ":" & Range("IV" & n).End(xlToLeft).Address)
Set plage = Range("G" & n)


plage.Copy

nbl = plage.Rows.Count
WordApp.Selection.Paste
WordApp.Selection.MoveUp Unit:=wdLine, Count:=nbl
If Selection.Information(wdWithInTable) = True Then
WordApp.Selection.Rows.ConvertToText Separator:=" ", NestedTables:=True ', vbCr
Else
MsgBox "The insertion point is not in a table."
End If
Selection.Collapse Direction:=wdCollapseEnd
Selection.EndKey Unit:=wdStory, Extend:=wdMove

With WordApp
For Each C In Range("H" & n & ":" & Range("IV" & n).End(xlToLeft).Address)
If C <> 0 Then .Selection.TypeText Text:=C.Text & " "
Next C
.Selection.TypeParagraph 'vbCr

Call IntegreFichierXL(Chemin & "\" & Classeur1, NDGusse, WordApp.Selection)
Call IntegreFichierXL(Chemin & "\" & Classeur2, NDGusse, WordApp.Selection)
Call IntegreFichierXL(Chemin & "\" & Classeur3, NDGusse, WordApp.Selection)
Call IntegreFichierXL(Chemin & "\" & Classeur4, NDGusse, WordApp.Selection)
Call IntegreFichierXL(Chemin & "\" & Classeur5, NDGusse, WordApp.Selection)

If Not n = derligne Then WordApp.Selection.InsertBreak Type:=wdPageBreak
End With
Next n

MsgBox "Fin traitement"
WordDoc.SaveAs Filename:=Chemin & "\Dico.doc"

' WordApp.Quit 'Pour Fermer Word
Set WordApp = Nothing
Set WordDoc = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

[C@thy]

Re : formule ou macro pour prénom

EUREKAAAAA

J'ai mis Selection. au lieu de WordApp.Selection. ça pouvait pas marcher!!!!

Biz

C@thy

 

[pierrejean]

Re : formule ou macro pour prénom

Re

Eh bien ! un tres grand BRAVO
Bises