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
| Sub Bouton1_Cliquer()
Application.ScreenUpdating = False
Chemin = ThisWorkbook.Path
With Sheets("Archive")
.Activate
NbreX = Application.CountIf(.Range(.[AB2], .[AB65536]), "x")
If NbreX = 0 Then
MsgBox "Il n'y a pas d'étiquette à extraire.", vbInformation + vbOKOnly
.Range("A1").Select
Exit Sub
End If
End With
Sheets("Archive").Copy
ActiveWorkbook.Close savechanges:=True, Filename:=Chemin & "\Temp.xls"
ChDir ThisWorkbook.Path
FileMailing = Application.GetOpenFilename("Fichiers Word (*.doc), *.doc", , "Ouvrir le document Word pour le mailing d'étiquettes ...")
If FileMailing = False Then End
'Si c'est OK on incrémente la référence
[J2] = [J2] + 1
' Ouverture de Word
Dim AppWord As Word.Application
Set AppWord = New Word.Application
AppWord.Visible = True 'False 'True
Set DocWord = AppWord.Documents.Open(FileMailing)
NomBase = Chemin & "\Temp.xls"
With DocWord.MailMerge
.OpenDataSource Name:=NomBase, _
Connection:="Driver={Microsoft Excel Driver (*.xls)};" & "DBQ=" & _
NomBase & "; ReadOnly=True;", SQLStatement:="SELECT * FROM [Archive$] WHERE [ETIQUETTE] like 'x' OR [ETIQUETTE] like 'X'"
'Spécifie la fusion vers un nouveau document (wdSendToPrinter= Vers l'imprimante)
.Destination = wdSendToNewDocument
'.SuppressBlankLines = True 'Il ne peut pas y voir de ligne blanche car on demande celle qui ont des croix
'Prend en compte l'ensemble des enregistrements
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
'Exécute l'opération de publipostage
.Execute Pause:=False
ActiveDocument.Fields.Update
End With
' Activation du doucment principal de Publipostage et fermeture
DocWord.Activate
DocWord.Close savechanges:=False
' Affichage l'application Word
AppWord.Visible = True
Set DocWord = Nothing
Set AppWord = Nothing
' Activation de l'onglet
' Effacement du fichier temporaire crée spécialement pour la fusion
Kill Chemin & "\temp.xls"
Application.ScreenUpdating = True
End Sub |
Partager