Discussion :

[Matrixmax]

Bonjour,

Je suis arrivé enfin à la phase finale de mon projet , qui consiste à transférer un tableau de résultat finale vers word .

cette fois ci je ne vais pas te poser la question nue mais je joint avec ce poste un code que j'ai développer et qui consiste à transféer une selection vers une page word vierge et je joint aussi le fichier excel contenant le tableau à transférer.

bon; ce qui est demandé ,c'est de transférer le tableau 16colonne par 16 colonne et si le nombre de colonne n'est pas un multiple de 16 , la derniére copie seras le reste des colonne .

mais on devrais repecter :

*reopier au début de chaque tableau la labell ( premiére colonne du tableau principale )

*garder un ecart de ( deux saut de ligne ) entre chaque tableau et autre.

*titré chaque tableau de "Résultat 1" à "Résultat N"

Merci beaucoup d'avance, je suis hyper heureux d'avoir arriver à ce stade et plus heureux d'explorer ce monde de programmation.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
 
 
Private Sub CommandButton1_Click()
 
Application.ScreenUpdating = False
 
    Dim WordApp As Word.Application
    Dim WordDoc As Word.Document
    Dim Fichier As String
    Dim A As Variant
 
 
 
 
    A = Application.GetOpenFilename()
 
 
    'le document Word est supposé fermé avant le lancement de la macro
    Fichier = "A"
 
    ' Si Le fichier n'est pas selectionné "msgbox" :D
 
    If A = False Then
    MsgBox " Aucun fichier n'a été selectionné"
 
Else
 
'necessite d'activer la reference Microsoft Word xx.x Object Library
 
Set WordApp = New Word.Application
 
WordApp.Visible = True
 
Set WordDoc = WordApp.Documents.Open(A)
 
 
'//////////////////////////////copie
 
 
Dim P As Range
Dim j As Variant
 
j = 0
On Error Resume Next
R:     Set P = Application.InputBox("Sélectionnez Le tableau" & j + 1 & "à exporter :", Type:=8)
 
    P.Copy
 
    WordApp.Selection.PasteSpecial
 
    WordDoc.Selection.End
 
    WordApp.Selection.InsertBreak Type:=1
    j = j + 1
 
    If j = 2 Then GoTo f Else: GoTo R
    On Error GoTo 0
 
f:
 
'////////////////////////////
 
For i = 1 To WordDoc.Tables.Count
 
WordDoc.Tables(i).AutoFitBehavior wdAutoFitWindow
WordDoc.Tables(i).Select
Selection.VerticalAlignment = wdCellAlignVerticalCenter
 
Next i
 
 
 
Application.CutCopyMode = True
 
    WordDoc.Close
 
    'ferme l'application Word
 
    WordApp.Quit
 
End If
 
 
 
    Sheets(1).Select
    ActiveSheet.Range("A1").Select
    Sheets(3).Select
    ActiveSheet.Range("A1").Select
    Sheets(4).Select
    ActiveSheet.Range("A1").Select
 
End Sub

[QuestVba]

Bonjour,

je joint aussi le fichier excel contenant le tableau à transférer

Je n'ai pas vu le ficheir à transférer ?!

Peux-tu éventuellement joindre un fichier Word exposant le résultat final ? (pour être certain de ne pas partir sur une mauvaise piste.

[Matrixmax]

Bonjour,

Je viens de finir le travail ce WE ... .. sur l'exportation d'un tableau de résultats existant sur une feuil excel appellée ( "Exporter vers word" ).

c'est ton tour maintenant chef de me parfaitiser le code débutant que j'ai fais

au début j'ai découpé le grand tableau en de ptits tableau de 17 colonne chacun sur la méme feuil excel.

aprés j'ai exporter chacun de ces tableau vers un nouveau fichier word.

Il me reste maintenant que d'optimiser mon code ... renommé mon fichier que j'ai créé . et ensuitte mettre avant chacun de mes tableau un titre : Tableau + le numéro d'index du tableau (pour que je puisse différer entre eux).

CODE :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
 
 
Private Sub CommandButton1_Click()
 
Application.ScreenUpdating = False
 
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Set WordApp = New Word.Application
WordApp.Visible = True
Set WordDoc = WordApp.Documents.Add
 
With WordDoc.PageSetup
        .LeftMargin = CentimetersToPoints(1)
        .RightMargin = CentimetersToPoints(0.5)
        .TopMargin = CentimetersToPoints(1.5)
        .BottomMargin = CentimetersToPoints(2)
    End With
 
Dim j, i, nb, k As Variant
Dim Cr As Integer
 
Cr = Worksheets(Sheets.Count).Cells(12, 2).End(xlToRight).Column
 
'//////////////////////////////copier la colonne 1
 
If Cr > 2 Then
 
    Rows("25:25").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.Clear
    ActiveSheet.Shapes.Range(Array("CommandButton1")).Select
 
 
nb = Int(Cr / 16)
 
i = 26
 
For j = 1 To nb
Range("A1:A23").Copy
Range(Cells(i, 1), Cells(i + 23, 1)).PasteSpecial
i = i + 26
Next j
 
If (Cr - nb * 16) > 1 Then
Range("A1:A23").Copy
Range(Cells(i, 1), Cells(i + 23, 1)).PasteSpecial
End If
 
i = 26
 
For j = 0 To nb - 1
 
Range(Cells(1, (16 * j + 2)), Cells(23, 16 * (j + 1) + 1)).Copy
Range("B" & i).Resize(23, 16).PasteSpecial
Range("A" & i).Resize(23, 17).Copy
 
WordApp.Selection.EndKey Unit:=wdStory
WordApp.Selection.PasteSpecial
 
WordApp.Selection.InsertBreak Type:=1
i = i + 26
 
Next j
 
If (Cr - nb * 16) > 1 Then
 
Range(Cells(1, (16 * nb) + 2), Cells(23, Cr)).Copy
 
Range("B" & i).Resize(23, Cr - nb).PasteSpecial
 
Range("A" & i + 3).Select
 
k = Worksheets(Sheets.Count).Cells(i + 3, 1).End(xlToRight).Column
 
Range(Cells(i, 1), Cells(i + 23, k)).Copy
 
WordApp.Selection.EndKey Unit:=wdStory
 
WordApp.Selection.PasteSpecial
 
 
End If
 
Application.CutCopyMode = False
 
Range("A1").Select
 
For i = 1 To WordDoc.Tables.Count
 
WordDoc.Tables(i).AutoFitBehavior wdAutoFitWindow
WordDoc.Tables(i).Select
Selection.VerticalAlignment = wdCellAlignVerticalCenter
 
Next i
 
End If
 
End Sub

ci joint le fichier excel contenant le tableau :

Merci pour ton interrét chef ..

[QuestVba]

Salut,

Voici la modification du code. J'ai mis en rouge les ajouts: variable pour compter tes tableaux + enregistrement

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
Private Sub exporter()
   
Dim Msg, Style, Title, Help, Ctxt, Response
Msg = "Traitement terminé ,Voulez vous exporter les résultat vers Word ?"    ' Définit le message.

Style = vbYesNo + vbCritical + vbDefaultButton2    ' Définit les boutons.

Title = "exporter les résultats"    ' Définit le titre.

' Affiche le message.
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then    ' L'utilisateur a choisi Oui.

Application.ScreenUpdating = False

Dim WordApp As Word.Application
Dim WordDoc As Word.Document

Set WordApp = New Word.Application
WordApp.Visible = True

Set WordDoc = WordApp.Documents.Add
'paramétrage des marges
With WordDoc.PageSetup
        .LeftMargin = CentimetersToPoints(1)
        .RightMargin = CentimetersToPoints(0.5)
        .TopMargin = CentimetersToPoints(1.5)
        .BottomMargin = CentimetersToPoints(2)
    End With
Dim j, i, nb, k As Variant
Dim Cr As Integer

Cr = Worksheets(Sheets.Count).Cells(12, 2).End(xlToRight).Column

'//////////////////////////////copier la colonne 1

If Cr > 2 Then

    Rows("25:25").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.Clear
    

nb = Int(Cr / 16)

i = 26

For j = 1 To nb
Range("A1:A23").Copy
Range(Cells(i, 1), Cells(i + 23, 1)).PasteSpecial
i = i + 26
Next j

If (Cr - nb * 16) > 1 Then
Range("A1:A23").Copy
Range(Cells(i, 1), Cells(i + 23, 1)).PasteSpecial
End If

i = 26
x = 0
For j = 0 To nb - 1

Range(Cells(1, (16 * j + 2)), Cells(23, 16 * (j + 1) + 1)).Copy
Range("B" & i).Resize(23, 16).PasteSpecial
Range("A" & i).Resize(23, 17).Copy

WordApp.Selection.EndKey Unit:=wdStory
x = x + 1
WordApp.Selection.TypeText Text:="Tableau " & x
WordApp.Selection.PasteSpecial

WordApp.Selection.InsertBreak Type:=1
i = i + 26

Next j

If (Cr - nb * 16) > 1 Then
x = x + 1
Range(Cells(1, (16 * nb) + 2), Cells(23, Cr)).Copy

Range("B" & i).Resize(23, Cr - nb).PasteSpecial

Range("A" & i + 3).Select

k = Worksheets(Sheets.Count).Cells(i + 3, 1).End(xlToRight).Column

Range(Cells(i, 1), Cells(i + 23, k)).Copy

WordApp.Selection.EndKey Unit:=wdStory
WordApp.Selection.TypeText Text:="Tableau " & x
WordApp.Selection.PasteSpecial

WordApp.Selection.WholeStory

 With WordApp.Selection.ParagraphFormat
        .SpaceBeforeAuto = False
        .SpaceAfterAuto = False
 End With
 With WordApp.Selection.ParagraphFormat
        .SpaceBefore = 0
        .SpaceBeforeAuto = False
        .SpaceAfter = 0
        .SpaceAfterAuto = False
        .LineSpacingRule = wdLineSpaceSingle
        .LineUnitBefore = 0
        .LineUnitAfter = 0
    End With

End If
WordApp.ActiveDocument.SaveAs "C:\temp\test.doc"

Application.CutCopyMode = False

Range("A1").Select

End If

End If

End Sub

[Matrixmax]

Yopp ... on y est ...

c'est exactement ce que je voulais ..

Merci Quest VBA ... bonne joutnée Chef !!

Probléme Résolu !!