publipostage par vba

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
E

eideal44

XLDnaute Junior
Bonjour,

J'aurais besoin d'un coup de main car mon code vba n'arrive pas a ouvrir la base de données depuis excel pour faire un publipostage.

Voilà j'ai écris cette macro qui m'ouvre un fichier excel, le met en forme, me sélectionne les données et me les recopie dans un autre classeur mais à présent j'aimerais qu'il me fasse un publipostage avec le fichier qu'il a ouvert mais ça bloque au moment de trouver la base de données.

J'ai bien mis la référence dans la bibliothèque, j'ai modifier, bouger le code dans tous les sens , essayer de comprendre ce qui ne vas pas mais je ne vois pas.

Si vous pouviez m'aider, ça serait génial.

Je ne peux pas vous mettre le fichier car il trop gros.

Voici mon code :


'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'TRAITEMENTS
Private Sub TRAITEMENTS_Click()

Dim TRAITEMENT, Derlig, wbSource
Dim i, c
Dim j, k, nomFichier
Dim VERIF, r
'*****************
'WORD
Dim docWord As Word.Document
Dim appWord As Word.Application
Dim NomBase As String


'**********************************************************************
'verification du referencement
With Sheets(ListBox3.Value)
For i = 6 To 11
If .Cells(5, i).Value <> "" And .Cells(8, i).Value <> "" Then
.Cells(3, i) = "ok"
.Cells(3, i).Font.ColorIndex = 2
End If
If .Cells(5, i).Value = "" And .Cells(8, i).Value = "" Then
.Cells(3, i) = "ok"
.Cells(3, i).Font.ColorIndex = 2
End If
If .Cells(5, i).Value <> "" And .Cells(8, i).Value = "" Then
.Cells(3, i) = "non"
.Cells(3, i).Font.ColorIndex = 2
End If
Next i

For Each c In .Range("F3:K3")
If c = "non" Then
REFERENCEMENT.Show
End If
Next c


End With

'**********************************************************************
'ouvrir fichier
wbSource = ActiveWorkbook.Name

TRAITEMENT = Application.GetOpenFilename("Fichiers Microsoft Office Excel,*.xls;*.xlt;*.xla")

nomFichier = Mid(TRAITEMENT, InStrRev(TRAITEMENT, "\") + 1)
nomFichier = Mid(nomFichier, InStrRev(nomFichier, "\") + 1)

'verifier ouverture du fichier
If nomFichier = wbSource Then
Call MsgBox("Le classeur que vous avez choisi est déja ouvert !" & Chr(10) & "Merci de le fermer avant de passer au TRAITEMENT !", vbCritical, "OPERATION IMPOSSIBLE ")
Unload SORTIES
Unload DONNEES
Exit Sub
End If

'On sort si aucun fichier n'a été sélectionné ou si l'utilisateur a cliqué sur le bouton Annuler ou sur la croix de fermeture
If TRAITEMENT = False Then Exit Sub

'Ouvre le fichier sélectionné
Workbooks.Open TRAITEMENT

'**********************************************************************
'copier les données

With ActiveWorkbook.Sheets(1)

'format
.Cells(3, 1).Copy .Cells(13, 20) 'copier nom du parc
.Range("A1:A11").EntireRow.Delete 'supprimer ligne 1 a 11

'supprimer colonnes et deplacer vers la gauche
.Columns("A:A").Delete Shift:=xlToLeft
.Columns("E:F").Delete Shift:=xlToLeft
.Columns("K😛").Delete Shift:=xlToLeft

.Cells(1, 1) = "ID"
.Cells(1, 2) = "DATE"
.Cells(1, 3) = "QTE"
.Cells(1, 4) = "REF"
.Cells(1, 5) = "NOM"
.Cells(1, 6) = "PRENOM"
.Cells(1, 7) = "ADRESSE1"
.Cells(1, 8) = "ADRESSE2"
.Cells(1, 9) = "CP"
.Cells(1, 10) = "VILLE"
.Cells(1, 11) = "PARC"

'copier nom du parc jusqu'à la derniere ligne
For i = 2 To .Cells(65000, 1).End(xlUp).Row
.Cells(2, 11).Copy .Cells(i, 11)
Next i

'***************************************************
'tester les valeurs REFERENCES

For k = 2 To .Cells(65000, 4).End(xlUp).Row
VERIF = .Cells(k, 4)
Set r = ThisWorkbook.Sheets(ListBox3.Value).Range("F8:K8").Find(VERIF)

'si VBA n'a pas trouvé
If r Is Nothing Then
MsgBox "la valeur " & VERIF & " n'a pas été trouvée. Merci de vérifier les REFERENCES rentrées", vbOKOnly + vbCritical, "ERREUR"
ThisWorkbook.Sheets(ListBox3.Value).Cells(4, 37) = VERIF
'fermer le fichier
ActiveWorkbook.Close False
'ouvrir l'userform REFERENCEMENT
REFERENCEMENT.Show
Exit Sub
End If

Next k

'***************************************************
'copier les informations

j = ThisWorkbook.Sheets(ListBox3.Value).Cells(65000, 12).End(xlUp).Row + 1
For i = 2 To .[a65000].End(xlUp).Row

ThisWorkbook.Sheets(ListBox3.Value).Range("L" & j).Value = .Range("B" & i).Value
ThisWorkbook.Sheets(ListBox3.Value).Range("M" & j).Value = .Range("A" & i).Value
ThisWorkbook.Sheets(ListBox3.Value).Range("N" & j).Value = .Range("E" & i).Value


If .Range("D" & i).Value = ThisWorkbook.Sheets(ListBox3.Value).Range("F8") Then
ThisWorkbook.Sheets(ListBox3.Value).Range("O" & j).Value = .Range("C" & i).Value
ElseIf .Range("D" & i).Value = ThisWorkbook.Sheets(ListBox3.Value).Range("G8") Then
ThisWorkbook.Sheets(ListBox3.Value).Range("P" & j).Value = .Range("C" & i).Value
ElseIf .Range("D" & i).Value = ThisWorkbook.Sheets(ListBox3.Value).Range("H8") Then
ThisWorkbook.Sheets(ListBox3.Value).Range("Q" & j).Value = .Range("C" & i).Value
ElseIf .Range("D" & i).Value = ThisWorkbook.Sheets(ListBox3.Value).Range("I8") Then
ThisWorkbook.Sheets(ListBox3.Value).Range("R" & j).Value = .Range("C" & i).Value
ElseIf .Range("D" & i).Value = ThisWorkbook.Sheets(ListBox3.Value).Range("J8") Then
ThisWorkbook.Sheets(ListBox3.Value).Range("S" & j).Value = .Range("C" & i).Value
ElseIf .Range("D" & i).Value = ThisWorkbook.Sheets(ListBox3.Value).Range("K8") Then
ThisWorkbook.Sheets(ListBox3.Value).Range("T" & j).Value = .Range("C" & i).Value
End If

'mettre 0 si cellule vide
With ThisWorkbook.Sheets(ListBox3.Value)
For Each c In .Range("O" & j & ":T" & j)
If c.Value = "" Then
c.Value = "0"
End If
Next c

'TOTAL VENTE
.Range("V" & j).Value = .Cells(j, 15) * .Cells(7, 15)
.Range("W" & j).Value = .Cells(j, 16) * .Cells(7, 16)
.Range("X" & j).Value = .Cells(j, 17) * .Cells(7, 17)
.Range("Y" & j).Value = .Cells(j, 18) * .Cells(7, 18)
.Range("Z" & j).Value = .Cells(j, 19) * .Cells(7, 19)
.Range("AA" & j).Value = .Cells(j, 20) * .Cells(7, 20)


'SOMME MARGE
If .Range("V" & j).Value <> "0" Then
.Range("AF" & j).Value = (.Cells(j, 28) - (.Cells(j, 15) * (.Cells(6, 15))))
Else
.Range("AF" & j).Value = ""
End If

If .Range("W" & j).Value <> "0" Then
.Range("AG" & j).Value = (.Cells(j, 28) - (.Cells(j, 16) * (.Cells(6, 16))))
Else
.Range("AG" & j).Value = ""
End If

If .Range("X" & j).Value <> "0" Then
.Range("AH" & j).Value = (.Cells(j, 28) - (.Cells(j, 17) * (.Cells(6, 16))))
Else
.Range("AH" & j).Value = ""
End If

If .Range("Y" & j).Value <> "0" Then
.Range("AI" & j).Value = (.Cells(j, 28) - (.Cells(j, 18) * (.Cells(6, 16))))
Else
.Range("AI" & j).Value = ""
End If

If .Range("Z" & j).Value <> "0" Then
.Range("AJ" & j).Value = (.Cells(j, 28) - (.Cells(j, 19) * (.Cells(6, 16))))
Else
.Range("AJ" & j).Value = ""
End If

If .Range("AA" & j).Value <> "0" Then
.Range("AK" & j).Value = (.Cells(j, 28) - (.Cells(j, 20) * (.Cells(6, 16))))
Else
.Range("AK" & j).Value = ""
End If

.Range("AD" & j).Value = .Range("AF" & j).Value + .Range("AG" & j).Value + .Range("AH" & j).Value + .Range("AI" & j).Value + .Range("AJ" & j).Value + .Range("AA" & j).Value
.Range("AD" & j).NumberFormat = "0.00"

.Range("V" & j & ":AA" & j).NumberFormat = "0.00"

.Range("AF" & j & ":AK" & j).Clear

End With

j = j + 1

Next i

End With


'***************************************************
'VALIDATION
MsgBox "Vos données de TRAITEMENT ont bien été ajoutées !", vbOKOnly + vbInformation, "INFORMATION"


'***************************************************
'mettre a jour la feuille selectionnée du fournisseur
With ThisWorkbook.Sheets(ListBox3.Value)
.Columns("C:BA").HorizontalAlignment = xlCenter 'centré
.Range("L14:T800").Borders.Weight = xlThin 'encadré
End With



'**********************************************************************
'PUPLIPOSTAGE et IMPRESSION des COURRIERS
Select Case MsgBox("Souhaitez-vous imprimer les courriers ?", vbQuestion + vbYesNo, "COURRIER")

'****************************************
'SI OUI
Case vbYes

NomBase = "J:\EXCEL\BILLETERIE\TRAITEMENTS\export_disneyland_paris_20120125_030006_6.xls"

Application.ScreenUpdating = False
Set appWord = New Word.Application
appWord.Visible = True
'Ouverture du document principal Word
'fichier sur clé
Set docWord = appWord.Documents.Open("J:\EXCEL\BILLETERIE\PUBLIPOSTAGE.doc")

'C'EST CI-DESSOUS QUE CA NE FONCTIONNE PAS :

'fonctionnalité de publipostage pour le document spécifié
With docWord.MailMerge
'Ouvre la base de données
.OpenDataSource Name:=NomBase, _
Connection:="Driver={Microsoft Excel Driver (*.xls)};" & _
"DBQ=" & NomBase & "; ReadOnly=True;", _
SQLStatement:="SELECT * FROM 'export_disneyland_paris_2012012$'"

'Spécifie la fusion vers l'imprimante
.Destination = wdSendToPrinter
.SuppressBlankLines = True

'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
End With

Application.ScreenUpdating = True

'Fermeture du document Word
docWord.Close False
appWord.Quit



'****************************************
'SI NON
Case vbNo
ActiveWorkbook.Close False


End Select


'**********************************************************************
'tout fermer
Unload SORTIES

'fermer la feuille TRAITEMENT
ActiveWorkbook.Close False

End Sub

'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

Si vous pouviez jeter un coup d'oeil et me dire ce qui ne va pas, ça serait vraiment trop bien.

Petite précision, le fichier NomBase doit correspondre au fichier excel ouvert : active workbooks.

Je tiens à vous remercier d'avance car là, je n'arrive plus à avancer.


Eideal44
 
Trier par date Trier par votes
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

C
  • Question Question
XL 2021 VBA excel
Réponses
4
Affichages
76
CDALE
C
K
  • Résolu(e)
XL 2016 Affichage TextBox
Réponses
6
Affichages
94
KRUG WOO
K
C
  • Question Question
Microsoft 365 worksheet_change
2
Réponses
29
Affichages
247
CortoXls
C
G
  • Question Question
Microsoft 365 Export données
Réponses
4
Affichages
498
GClaire
G
G
  • Résolu(e)
XL 2016 Pb de tri et sous totaux
2
Réponses
27
Affichages
331
Gestionnaire_rh
G
G
  • Résolu(e)
XL 2021 VBA dates au mauvais format
Réponses
5
Affichages
313
vgendron
vgendron
T
  • Résolu(e)
XL 2016 macro et feuille protégé
2
Réponses
18
Affichages
731
laurent950
laurent950
Nicolas JACQUIN
  • Question Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
1 K
Nicolas JACQUIN
Nicolas JACQUIN
A
  • Question Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
216
patricktoulon
patricktoulon
lynyrd
  • Question Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
598
AtTheOne
AtTheOne
C
  • Question Question
XL 2021 Problème de remplissage d'une colonne conditionné à d'autres valeurs
Réponses
2
Affichages
428
CathyLD
C
M
  • Question Question
XL 2010 Aide à la suppression d'un produit en double dans un magasin spécifique avec conditions
Réponses
9
Affichages
789
Mody200
M
A
  • Résolu(e)
XL 2016 Recherche d'un mot dans une cellule et surlignage de la ligne
Réponses
4
Affichages
105
Abi23
A
P
  • Résolu(e)
XL 2013 EXCEL VBA
Réponses
2
Affichages
372
pangasoul
P
D
  • Question Question
XL 2021 Filtre Multi Critères Listview VBA
2
Réponses
21
Affichages
2 K
Dranreb
Dranreb
M
  • Question Question
Microsoft 365 Erreur sur mon Code VBA
Réponses
2
Affichages
403
Gégé-45550
Gégé-45550
thunder23
  • Résolu(e)
XL 2021 And/Or dans If
Réponses
3
Affichages
270
thunder23
thunder23
A
  • Question Question
Microsoft 365 Code VBA Envoi contenu tableau Excel par Email
Réponses
1
Affichages
444
Phil69970
Phil69970
S
  • Résolu(e)
Microsoft 365 VBA Match: comment éviter l'erreur?
2
Réponses
29
Affichages
547
Dranreb
Dranreb
klin89
  • Question Question
Microsoft 365 Méthode Evaluate pour se dispenser d'une boucle imbriquée
Réponses
14
Affichages
394
patricktoulon
patricktoulon
Retour