Récupération de partie de tableau Excel à envoyer vers un document Word
Bonjour,
Je débute en VBA, j'apprends à le faire en autodidacte du coup je ne pense pas ecrire le code de la meilleure façon, cela étant voici mon probleme.
J'ai un fichier word qui contient des images et des tableaux ainsi que du texte, et je cherche à intégrer dans ce fichier des tableaux d'un fichier excel (ce fichier à N (variable) onglets) les tableaux n'ont pas forcément la même taille.
Les tableaux sont copiés/collés dans le word à un emplacement précis (j'utilise des mots clés intégrés au texte du fichier, exemple <motcle> et <motcle\>)
Mon problème est le suivant, lorsque je suis en pas à pas, il n'y a pas de réel soucis, l'exportation vers word fonctionne, par contre si je me place comme un utilisateur lambda, j'ai une erreur de clipboard erreur 4605 que je ne comprends pas
Auparavant j'utilisais le PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine, DisplayAsIcon:=False mais j'ai un souci d'ordre cosmétique en effet les tableaux arrivent avec des tailles qui ne conviennent pas et je ne sais pas comment les tailler (autofit) à la largeur de la page.
Avec PasteExcelTable cela semble mieux, mais je perds la mise en page (couleur, alignement, etc...) et lorsque je ne suis pas en pas à pas j'ai l'erreur 4605 qui plante le script
Voici le code, si une âme charitable peut m'aider
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
| Dim ExcelApp As Excel.Application
Dim SelDOCFile As Selection
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim User As String, File_Word As String, Filename As String
Dim Change As Boolean, REGMAP_Balise As Boolean, REGMAPDFT_Balise As Boolean, OTPMAP_Balise As Boolean
Change = False
REGMAP_Balise = False
REGMAPDFT_Balise = False
OTPMAP_Balise = False
User = Environ("userprofile")
User = Split(User, "\")(UBound(Split(User, "\")))
MsgBox ("Bonjour " & User & Chr(10) & "Veuillez sélectionner le fichier Word PTS")
Change = False
ChDir ActiveWorkbook.Path
File_Word = Application.GetOpenFilename("Document Word, *.doc;*.docm;*.docx")
If Split(File_Word, "\")(UBound(Split(File_Word, "\"))) = False Then
MsgBox ("Abandon")
Exit Sub
End If
Filename = Split(File_Word, "\")(UBound(Split(File_Word, "\")))
'nécéssite d'activer la reference Microsoft word xx.x 0bject Library
On Error Resume Next
Set WordApp = GetObject(, "Word.Application")
Set WordDoc = WordApp.Documents.Open(File_Word)
Set ExcelApp = GetObject(, "Excel.Application")
On Error GoTo 0
'Traitement différent si le document est déjà ouvert
If WordDoc Is Nothing Then
'le document est fermé
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
Set WordDoc = WordApp.Documents.Open(Filename:=File_Word)
WordApp.Documents(File_Word).Activate
Else
'Le document est ouvert
WordApp.Documents(File_Word).Activate
End If
On Error Resume Next
CaptionLabels.Add Name:="[Table"
On Error GoTo errorHandler
Set SelDOCFile = WordApp.Selection |
là il s'agit donc de la partie déclaration etc...
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
| 'ClearClipboard
'On colle les tableaux
SelDOCFile.HomeKey Unit:=wdStory ' place le cursaur en debut du document
With SelDOCFile.Find
.Forward = True
.Wrap = wdFindContinue
.Execute FindText:="\<motcle\>"
If .Found And REGMAP_Balise Then
Change = True
SelDOCFile.MoveRight Unit:=wdCharacter, Count:=1
SelDOCFile.TypeParagraph
For Each WS In ExcelApp.ActiveWorkbook.Sheets
If WS.Name = "REGMAP" Then
SelDOCFile.TypeParagraph
SelDOCFile.MoveUp Count:=1
SelDOCFile.InsertCaption Label:="[Table", Title:=": REGMAP]", Position:=wdCaptionPositionAbove, ExcludeLabel:=0
SelDOCFile.MoveRight Unit:=wdCharacter, Count:=1
TabDim = "B2:F" & ExcelApp.Sheets(WS.Name).Range("B2").End(xlDown).Row
ExcelApp.Sheets(WS.Name).Range(TabDim).Copy
'WordApp.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine, DisplayAsIcon:=False
SelDOCFile.PasteExcelTable False, True, False
SelDOCFile.TypeParagraph
Else
SelDOCFile.TypeParagraph
SelDOCFile.MoveUp Count:=1
SelDOCFile.InsertCaption Label:="[Table", Title:=": " & ExcelApp.Sheets(WS.Name).Range("D4").Value, Position:=wdCaptionPositionAbove, ExcludeLabel:=0
SelDOCFile.MoveRight Unit:=wdCharacter, Count:=1
Reglength = Len(Split(ExcelApp.Sheets(WS.Name).Range("H5").Value, "b")(0))
TabDim = "B4:H" & Reglength + 4 + 3
ExcelApp.Sheets(WS.Name).Range(TabDim).Copy
SelDOCFile.PasteExcelTable False, True, False
SelDOCFile.TypeParagraph
End If
Next
End If
End With |
c'est ici que le code plante lors du paste, auparavant je retouche le document word, mais cela n'a pas d'importance ici.
j'ai essayé de mettre ça pour bien vider le pressepapier, mais rien y fait
Code:
1
2
3
4
5
6
7
8
9
| Sub ClearClipboard()
Dim oDataObject As DataObject
Set oDataObject = New DataObject
oDataObject.SetText ""
oDataObject.PutInClipboard
Set oDataObject = Nothing
End Sub |
D'ailleurs est-il possible de modifier les paramètres du tableau qui est importé (copié/collé) ? car si j'ai compris il faut connaitre l'indice du tableau, mais dans mon cas cela est assez problématique (sans partir dans une usine à gaz ce que j'ai l'impression d'avoir déjà fait)
