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