Mise en forme Excel 2016 vers Word 2016
Le_Troll_Du_27Membre fidèle
- Messages
- 156
- Excel
- 2019 FR 64 Bits
- Inscrit
- 14/07/2015
- Emploi
- Ex-Conducteur Routier de convoi exceptionnel
Bonjour le forum
dans mon fichier quand j'exporte le contact il remplit un fichier dans word
le tableau est extrait mais je coince sur la mise en forme
NomDuFichier = ("D:\" & NomUtilisateur & "\Documents\Fichiers Clients\" & TextBox3.Value _
& " " & TextBox4.Value & " " & TextBox5.Value)
On Error Resume Next
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
Set WordDoc = WordApp.Documents.Add
WordApp.Selection.TypeText Text:="Détail du contact" ' .....................................Insère du texte au point d'insertion
WordApp.Selection.TypeParagraph ' ..........................................................Sauter une ligne
Wsz.Range("A1:B" & Wsz.Range("A" & Rows.Count).End(xlUp).Row).Select
Selection.Font.Name = "Courier New"
Selection.Font.Size = 10
Selection.Copy
WordDoc.Range.PasteSpecial ' ...............................................................Colle les données dans Word
' -------------->> mettre la liste extraite dans un tableau sans texture
' -------------->> Partie erronée
'Selection.Shading.Texture = WordDoc.TextureNone
'Selection.Shading.ForegroundPatternColor = WordDoc.ColorAutomatic
'Selection.Shading.BackgroundPatternColor = WordDoc.ColorAutomatic
'ActiveWindow.ActivePane.View.ShowAll = Not ActiveWindow.ActivePane.View.ShowAll
'Selection.Tables(1).Style = "Grille du tableau"
'ActiveWindow.ActivePane.View.ShowAll = Not ActiveWindow.ActivePane.View.ShowAl
' -------------->> fin de partie erronée
Application.CutCopyMode = False
WordDoc.SaveAs NomDuFichier ' ..............................................................Enregistre les modifications
WordApp.Quit ' .............................................................................Quitte Word
Set WordDoc = Nothing ' ....................................................................Vide l'objet en mémoire
Set WordApp = Nothing ' ....................................................................Vide l'objet en mémoire
MsgBox ("Document créé et rangé")
cordialement
Le_Troll_Du_27Membre fidèle
- Messages
- 156
- Excel
- 2019 FR 64 Bits
- Inscrit
- 14/07/2015
- Emploi
- Ex-Conducteur Routier de convoi exceptionnel
Bonjour le forum
Voici le code en entier :
'**** Correspond au programme du CommandButton "Exporter" ****
Private Sub CmdB_Exporter_Click() ' ........................................................Bouton Exporter
Set Wsz = Sheets("Feuille Temporaire")
Application.ScreenUpdating = False
For t = 1 To 68
If Me.Controls("Checkbox" & t).Value = True Then
GoTo LaSuite
Else
MsgBox "Vous n'avez rien coché !?", 48, "Attention"
Exit Sub
End If
Next t
LaSuite:
Wsz.Cells.ClearContents
For M = 1 To 68
If Me.Controls("CheckBox" & M).Value = True Then
Wsz.Cells(1, M).Value = Me.Controls("CheckBox" & M).Caption
Wsz.Cells(1, M).Interior.ColorIndex = 35 ' .....................................Vert
Wsz.Cells(1, M).Font.ColorIndex = 41 ' .........................................Bleu
Wsz.Cells(1, M).Font.Name = "Courrier New"""
Wsz.Cells(1, M).Font.FontStyle = "Gras"
Wsz.Cells(1, M).Font.Size = 12
Wsz.Cells(2, M).Value = Me.Controls("TextBox" & M).Value
Wsz.Cells(2, M).Font.Name = "Courrier New"
Wsz.Cells(2, M).Font.Size = 12
End If
Next M
Sheets("Feuille Temporaire").Select
With Sheets("Feuille Temporaire")
Range("A1:BP2").Select: Selection.Copy: Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Rows("1:2").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Columns("B:B").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.ColumnWidth = 45
.Range("A1").Select
DétruireLigne
.Range("B1").Interior.Color = xlNone
.Range("B1").Interior.Pattern = xlNone
.Range("B1").Font.ColorIndex = xlAutomatic
.Range("B1").Font.Bold = False
End With
Application.DisplayAlerts = True
' ---------------------------------------------------------------------------------------------
' Transferer les données exporter vers Word |
' ---------------------------------------------------------------------------------------------
NomDuFichier = ("D:\" & NomUtilisateur & "\Documents\Fichiers Clients\" & TextBox3.Value _
& " " & TextBox4.Value & " " & TextBox5.Value)
On Error Resume Next
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
Set WordDoc = WordApp.Documents.Add
WordApp.Selection.TypeText Text:="Détail du contact" ' .....................................Insère du texte au point d'insertion
WordApp.Selection.TypeParagraph ' ..........................................................Sauter une ligne
Wsz.Range("A1:B" & Wsz.Range("A" & Rows.Count).End(xlUp).Row).Select
Selection.Font.Name = "Courier New"
Selection.Font.Size = 10
Selection.Copy
WordDoc.Range.PasteSpecial ' ...............................................................Colle les données dans Word
' ---------------> Ma mise en forme dans Word
'Selection.Shading.Texture = WordDoc.TextureNone
'Selection.Shading.ForegroundPatternColor = WordDoc.ColorAutomatic
'Selection.Shading.BackgroundPatternColor = WordDoc.ColorAutomatic
'ActiveWindow.ActivePane.View.ShowAll = Not ActiveWindow.ActivePane.View.ShowAll
'Selection.Tables(1).Style = "Grille du tableau"
'ActiveWindow.ActivePane.View.ShowAll = Not ActiveWindow.ActivePane.View.ShowAl
Application.CutCopyMode = False
WordDoc.SaveAs NomDuFichier ' ..............................................................Enregistre les modifications
WordApp.Quit ' .............................................................................Quitte Word
Set WordDoc = Nothing ' ....................................................................Vide l'objet en mémoire
Set WordApp = Nothing ' ....................................................................Vide l'objet en mémoire
MsgBox ("Document créé et rangé")
Unload Me
End Sub
Si besoin du fichier, je le fournirai à la prochaine réponse
Cordialement
Le_Troll_Du_27Membre fidèle
- Messages
- 156
- Excel
- 2019 FR 64 Bits
- Inscrit
- 14/07/2015
- Emploi
- Ex-Conducteur Routier de convoi exceptionnel
bonsoir le forum
Je fais un UP car je ne comprends pas
Merci, cordialement