Cours et Tutoriels, Informatique

Transfert de données d’Excel vers Word et de Word vers Excel

Posted by author-avatar
0 comments

J’ai répondu récemment à des messages sur les forums Excel et Word pour réaliser des transferts de données depuis ou sur des ContentControls Word.

De Word vers Excel :

Le code balaye les fichiers .doc* présents dans le répertoire choisi et récupère les valeurs des ContentControls dans un tableau structuré.

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
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
 
Option Explicit

'Les déclarations des variables publiques sont stockées dans un module spécifique.

'Public sChemin As String, sNomFichier As String
'Public Continuer As Boolean

'Public WApp As Word.Application, WDoc As Word.Document, WSel As Word.Selection ' En Early Binding
' Public WApp As Object, WDoc As Object, WSel As Object                         ' En Late Binding
'Public TabBd As ListObject
'Public LigneBd As ListRow

'Public HeureDebut, HeureFin, HeureFin

Sub Importation_Donnees_Word()

   
    On Error GoTo Fin
    
    HeureDebut = Timer
   
    ChDir ActiveWorkbook.Path
  
    With UsfRepertoireWord
         .Show
    End With
    
    If Continuer = False Then GoTo Fin
    
    With Application
         .ScreenUpdating = False
         .Calculation = xlCalculationManual
    End With
    
    Set TabBd = Sheets("Import Word vers Excel").ListObjects("BaseDeDonnees")
    
    sNomFichier = Dir(sChemin & "*.doc*")
    
    Set WApp = CreateObject("Word.Application")
    WApp.Visible = True
        
    Do While Len(sNomFichier) > 0

        Set WDoc = WApp.Documents.Open(sChemin & sNomFichier, ReadOnly:=True)

        Set LigneBd = TabBd.ListRows.Add
        With LigneBd
             .Range(1, 1) = sNomFichier
             .Range(1, 2) = ValeurContentControls(WDoc, "NOM")
             .Range(1, 3) = ValeurContentControls(WDoc, "PRENOM")
             .Range(1, 4) = ValeurContentControls(WDoc, "CA")
             .Range(1, 5) = ValeurContentControls(WDoc, "GN")
             .Range(1, 6) = ValeurContentControls(WDoc, "B")
             .Range(1, 7) = ValeurContentControls(WDoc, "VILLE")
             .Range(1, 8) = ValeurContentControls(WDoc, "SEXE")
             .Range(1, 9) = ValeurContentControls(WDoc, "AGE")
             .Range(1, 10) = ValeurContentControls(WDoc, "STAGIAIRE")
             .Range(1, 11) = ValeurContentControls(WDoc, "INFO_ST")
             .Range(1, 12) = ValeurContentControls(WDoc, "HORS_ENTREPRISE")
             .Range(1, 13) = ValeurContentControls(WDoc, "INFO_ENT")
        End With
        Set LigneBd = Nothing
        
        WDoc.Close False
        sNomFichier = Dir
    Loop
    
    HeureFin = Timer
    TempsTotal = HeureFin - HeureDebut
    
    GoTo Fin
    
Fin:

    With Application
         .ScreenUpdating = True
         .Calculation = xlCalculationAutomatic
    End With

    If Continuer = True Then
       WApp.Quit
       MsgBox "Temps total du traitement : " & Round(TempsTotal, 0) & " seconde(s)"
    End If
    
    Set TabBd = Nothing: Set WDoc = Nothing: Set WApp = Nothing
    

End Sub

 
Function ValeurContentControls(ByVal WordDoc As Word.Document, ByVal TitreControle As String) As Variant
 
Dim I As Integer
 
    With WordDoc
         For I = 1 To .ContentControls.Count
             With .ContentControls(I)
                  If .Title = TitreControle Then
                     Select Case .Type
                            Case 8
                                 ValeurContentControls = .Checked
                            Case Else
                                 ValeurContentControls = .Range.Text
                      End Select
                      Exit Function
                  End If
            End With
        Next I
   End With
 
End Function

 

D’Excel vers Word :

Le code génère les fichiers docx dans le répertoire choisi et remplit les ContentControls avec les données présentes dans le tableau structuré. Cette méthode peut être un substitut à un publipostage.

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
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
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
 
Option Explicit

'Les déclarations des variables publiques sont stockées dans un module spécifique.

'Public RepertoireExport As String, ModeleExport As String
'Public Continuer As Boolean
'Public ShExport As Worksheet
'Public WApp As Word.Application, WDoc As Word.Document, WSel As Word.Selection  ' Early Binding, cocher la référence Microsoft Word
' Public WApp As Object, WDoc As Object, WSel As Object                          ' Late Binding
'Public TabExport As ListObject
'Public LigneBd As ListRow
'Public HeureDebut, HeureFin, HeureFin

Sub Exportation_Donnees_Excel()
   
Dim I As Integer
Dim NomExport As String

    On Error GoTo Fin
    
    HeureDebut = Timer
    ChDir ActiveWorkbook.Path
    
    Set ShExport = Sheets("Export Excel vers Word")
  
    With UsfExporterDansWord
         
         If ShExport.Range("ModeleFichierWord") <> "" Then
            If VerifierLeChemin(Split(ShExport.Range("ModeleFichierWord"), "Modèle Excel vers Word.docx")(0)) Then
               .TextBoxModeleWord = ShExport.Range("ModeleFichierWord")
            End If
         End If
         
         If ShExport.Range("RepertoireExport") <> "" Then
            If VerifierLeChemin(ShExport.Range("RepertoireExport")) Then
               .TextBoxRepertoireSauvegarde = ShExport.Range("RepertoireExport")
            End If
         End If
    
         .Show
         
    End With
    
    If Continuer = False Then GoTo Fin
    
    With ShExport
         Set TabExport = .ListObjects("BaseExport")
         If RepertoireExport <> "" And RepertoireExport <> "" Then
            .Range("RepertoireExport") = RepertoireExport
            .Range("ModeleFichierWord") = ModeleExport
         End If
    End With
    
    With Application
         .ScreenUpdating = False
         .Calculation = xlCalculationManual
    End With
    
    Set WApp = CreateObject("Word.Application")
    WApp.Visible = True
        
        
    For I = 1 To TabExport.ListRows.Count
        Set LigneBd = TabExport.ListRows(I)
        Set WDoc = WApp.Documents.Add(Template:=ModeleExport)
        With LigneBd
             ExportContentControls WDoc, "NOM", .Range(1, 1)
             ExportContentControls WDoc, "PRENOM", .Range(1, 2)
             ExportContentControls WDoc, "CA", .Range(1, 3)
             ExportContentControls WDoc, "GN", .Range(1, 4)
             ExportContentControls WDoc, "B", .Range(1, 5)
             ExportContentControls WDoc, "VILLE", .Range(1, 6)
             ExportContentControls WDoc, "SEXE", .Range(1, 7)
             ExportContentControls WDoc, "AGE", .Range(1, 8)
             ExportContentControls WDoc, "STAGIAIRE", .Range(1, 9)
             ExportContentControls WDoc, "INFOST", .Range(1, 10)
             ExportContentControls WDoc, "HORS_ENTREPRISE", .Range(1, 11)
             ExportContentControls WDoc, "INFO_ENT", .Range(1, 12)
             
             NomExport = RepertoireExport & .Range(1, 13) & ".docx"
             Debug.Print I & " : " & NomExport
             ShExport.Hyperlinks.Add .Range(1, 14), Address:=NomExport, TextToDisplay:="Lien"

             WDoc.SaveAs2 Filename:=NomExport, FileFormat:=16
             WDoc.Close savechanges:=True
             
        End With
        Set WDoc = Nothing: Set LigneBd = Nothing
        
    Next I
    
    HeureFin = Timer
    HeureFin = HeureFin - HeureDebut
    
    GoTo Fin
    
Fin:

    With Application
         .ScreenUpdating = True
         .Calculation = xlCalculationAutomatic
    End With

    If Continuer = True Then
       WApp.Quit
       MsgBox "Temps total du traitement : " & Round(HeureFin, 0) & " seconde(s)", vbInformation
    End If

    Set TabBd = Nothing: Set WDoc = Nothing: Set WApp = Nothing: Set ShExport = Nothing

End Sub



Sub ExportContentControls(ByVal WordDoc As Word.Document, ByVal TitreControle As String, ByVal ValeurControle As Variant)
 
Dim I As Integer
 
    With WordDoc
         For I = 1 To .ContentControls.Count
             With .ContentControls(I)
                  If .Title = TitreControle Then
                     Select Case .Type
                            Case 8
                                 .Checked = ValeurControle
                            Case Else
                                 .Range.Text = ValeurControle
                      End Select
                      Exit Sub
                  End If
            End With
        Next I
   End With
 
End Sub


Function VerifierLeChemin(ByVal Chemin2 As String) As Boolean

Dim Fso As Object
    
    VerifierLeChemin = False
    Set Fso = CreateObject("Scripting.FileSystemObject")
    VerifierLeChemin = Fso.FolderExists(Chemin2)
    Set Fso = Nothing

End Function
Newer Dubai Uptown Tower: premier gratte-ciel à utiliser la robotique pour l’installation d’ascenseurs
Back to list
Older WORD – Transformer un groupe de mots en lien hypertexte

Laisser un commentaire

Votre adresse e-mail ne sera pas publiée. Les champs obligatoires sont indiqués avec *