Macro création BD pour Publipostage

Bonjour le Forum,

Je reviens vers vous pour un petit coup de main sur une macro qui réaliserait le "dispatching" de données d'un tableau pour créer 2 bases de données.

Je vous explique : la première feuille "saisie" va être remplie par un utilisateur. Le nombre de lignes renseigné est complétement aléatoire!!

Une fois que toutes les colonnes sont renseignées ( de A à P, en sachant que les colonnes J,K,L,M,N,O seront cachées pour faciliter la lecture et le déplacement dans la feuille), il faudrait via une macro générer les 2 bases de données suivantes : "publi simple" et "publi multiple" (cf. feuilles crées dans le fichier).

Le choix du dispatching entre les feuilles de BD se fait via la colonne ("P") (liste déroulante).

La feuille "publi simple" est un report de valeur simple du tableau de la feuille "Saisie", en revanche attention la feuille "publi multiple" est un peu plus complexe, les données doivent être copiées mais re manipuler!!

J'ai donné la structure de base et l'idéal serait que tout cela se fasse de manière automatique bien sur^^ (cf.fichier joint)

J'espère que cela est possible?

Je vous joints le fichier en question pour test.

Je vous remercie d'avance pour votre aide...

20samsam07.rar (84.16 Ko)

Je re post mon fichier joint car j'ai constaté que la liste déroulante qui permet le choix de la base de données n'était pas présente^^

Je m'excuse pour ce petit bug.

Merci d'avance pour votre aide!

18samsam07.rar (82.89 Ko)

Re le forum,

J'ai réussi après quelques recherches et modifications à écrire le code suivant :

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, Range("P8:P" & Range("A" & 65536).End(xlUp).Row)) Is Nothing Then End
Dim lg As Integer
lg = ActiveCell.Row
With ActiveSheet
If lg = 8 Or .Range("P" & lg) = "" Or .Range("P" & lg) = "" Then Exit Sub
Select Case ActiveSheet.Range("P" & lg)
    Case Is = "publipostage simple"
        .Range("A" & lg & ":F" & lg).Copy Sheets("publi simple").Range("A" & Sheets("publi simple").Range("A" & Sheets("publi simple").Rows.Count).End(xlUp).Row + 1)
        .Range("H" & lg & ":H" & lg).Copy Sheets("publi simple").Range("G" & Sheets("publi simple").Range("G" & Sheets("publi simple").Rows.Count).End(xlUp).Row + 1)
        .Range("J" & lg & ":O" & lg).Copy Sheets("publi simple").Range("H" & Sheets("publi simple").Range("H" & Sheets("publi simple").Rows.Count).End(xlUp).Row + 1)

End Select
End With
End Sub

Alors il fonctionne, cependant pas "complétement" (ça aurait été trop beau^^ )

Si je le place dans dans ma feuille "Saisie", je pense qu'il rentre en conflit avec le reste du code de la page....

Si je le rattache à un bouton, je n'ai pas réussi à faire de boucle sur ma colonne "P", du coup, à chaque choix je dois lancer la macro pour qu'elle fonctionne (pas vraiment pratique)

De plus, serait-il possible de l'adapter pour que la copie ne soit pas figée -> c'est à dire qu'en cas d'erreur, si l'utilisateur choisit "publi multiple", bin la ligne soir effacée de "publi simple" et soit copiée dans "publi multiple"?

Dernière petite chose, ce code réalise une copie "complète" de la ligne (avec formule, mise en page etc....), serait-il possible de limiter la copie juste aux valeurs contenus dans les cellules??

Je remets le fichier en pièce jointe.

En espérant que quelqu'un réussisse à me débloquer??!!

Merci d'avance pour votre aide.

22samsam07.rar (82.24 Ko)

bonjour pour mettre le code pas sur la feuille mais dans un module

au lieu de faire

Select Case ActiveSheet.Range("P" & lg)
    Case Is = "publipostage simple"
        .Range("A" & lg & ":F" & lg).Copy Sheets("publi simple").Range("A" & Sheets("publi simple").Range("A" & Sheets("publi simple").Rows.Count).End(xlUp).Row + 1)
        .Range("H" & lg & ":H" & lg).Copy Sheets("publi simple").Range("G" & Sheets("publi simple").Range("G" & Sheets("publi simple").Rows.Count).End(xlUp).Row + 1)
        .Range("J" & lg & ":O" & lg).Copy Sheets("publi simple").Range("H" & Sheets("publi simple").Range("H" & Sheets("publi simple").Rows.Count).End(xlUp).Row + 1)
End Select

Fait plutot

Select Casesheets("saisie").Range("P" & lg)
    Case Is = "publipostage simple"
        .Range("A" & lg & ":F" & lg).Copy Sheets("publi simple").Range("A" & Sheets("publi simple").Range("A" & Sheets("publi simple").Rows.Count).End(xlUp).Row + 1)
        .Range("H" & lg & ":H" & lg).Copy Sheets("publi simple").Range("G" & Sheets("publi simple").Range("G" & Sheets("publi simple").Rows.Count).End(xlUp).Row + 1)
        .Range("J" & lg & ":O" & lg).Copy Sheets("publi simple").Range("H" & Sheets("publi simple").Range("H" & Sheets("publi simple").Rows.Count).End(xlUp).Row + 1)

End Select

de manière générale, ne pas utiliser de activesheet car on ne sais jamais de quelle feuille on parle, il faut cibler les feuilles pour savoir de quoi on parle....

fred

Bonjour Fred,

Merci pour le retour.

Mais même si je place cette macro dans un module, toute la colonne P n'est pas traitée???

A chaque choix en colonne "P", je dois lancer la macro pour copier la ligne.... pas super pratique^^

Un petit UP.....

Personne n'a une petite piste à me donner pour essayer de résoudre mon problème de macro?

MERCi....

Plus le temps pour le moment. Au boulot en ce qui me concerne

fred

Ok merci Fred!!!

Bon courage. bonne aprem.

A@

re

j'ai repris tout pour le publi simple, sub a attribuer à un bouton et dans un module

voici le code :

Option Explicit

Sub dispatching_simple()
Dim i, lg As Integer
Dim ShS, ShD As Worksheet

Set ShS = Sheets("saisie")
Set ShD = Sheets("publi simple")
'effacement des données presente dans la feuille publisimple
If ShD.Cells(Rows.Count, "A").End(xlUp).Row > 1 Then ShD.Range("A2:N" & ShD.Cells(Rows.Count, "A").End(xlUp).Row).ClearContents
For i = 7 To ShS.Cells(Rows.Count, "P").End(xlUp).Row
If ShS.Cells(i, "P") = "publipostage simple" Then
lg = ShD.Cells(Rows.Count, "A").End(xlUp).Row + 1
ShS.Range(ShS.Cells(i, "A"), ShS.Cells(i, "F")).Copy ShD.Cells(lg, "A")
ShS.Range(ShS.Cells(i, "H"), ShS.Cells(i, "H")).Copy ShD.Cells(lg, "G")
ShS.Range(ShS.Cells(i, "J"), ShS.Cells(i, "O")).Copy ShD.Cells(lg, "H")
End If
Next
'efface les bordures
ShD.Range("A2:N" & ShD.Cells(Rows.Count, "A").End(xlUp).Row).Borders.LineStyle = xlNone
End Sub

par contre pour ton publi multiple j'ai pas trop compris .... quelles sont les colonnes a copiées

fred

Re Fred,

Merci pour cette macro qui fait le boulot à merveille.!!!

En ce qui concerne le cas du "publi multi":

en fait je l'ai intitulé comme ça mais en fait cela concerne un ensemble d'agents qui vont tous avoir certaines infos en communs : à savoir= civilité2, titre, adresse3, adresse4, code postal2,ville2

De ce fait pour éviter de faire un publipostage par agent, je souhaite regrouper les différents agents dans le même document.

Ce qui explique qu'il faut regrouper les agents dans la même cellule, séparée par une virgule et insérer l'adresse en commun dans les cellules suivantes.... Je sais pas si j'ai pu être plus clair???

Je joints un fichier qui montre le résultat, ulta simplifié (sans la mise en forme, formule etc....) en espérant que cela aide à la compréhension du résultat recherché!!

Dans tous les cas, un grand MERCI pour le boulot fourni, c'est super sympa!!

C'est mon collègue qui va gagner un temps fou... une fois ce fichier finalisé et opérationnel!!

Donc au final combien de lignes pourront être présentent dans la feuille publimultiple ?? Toujours une seule ?? Ou plusieurs ?? Et dans ce cas comment se différencies les lignes par quel moyen

fred

Oui effectivement, dans la feuille "publi multiple" il y a de forte chance qu'il y est besoin d'une ligne pour la sous partie "Département de l'Ardèche" et peut-être aussi pour la sous partie "SDIS" (mais le cas d'agents multiple est plus faible et moins fréquent que pour la sous partie "département de l'Ardèche, mais si c'est possible de prévoir le cas.... ça serait idéal!! )

le choix se fera toujours depuis la liste déroulante en P (-> "publi multiple")

De plus, est -il possible de rajouter pour chaque ligne, la date du Comité à savoir la valeur insérer en C3 de la feuille "Saisie"

Si cela est possible, c'est le top du top ^^

Bonjour Fred2406 et le reste du forum,

J'ai essayé de bosser un peu sur le bout de code écris pour le publipostage simple et tenter d'insérer le cas pour le publi pultiple mais je rencontre quelques difficultés d'écriture je pense!! En effet, lorsque je lance la macro, pas de message d'erreur mais tout se passe pas comme prévu :

la partie publi simple = pas de soucis

la partie publi multiple = seules les données en A et B sont copiées. De plus, en cas de relance de la macro, les données

ne sont pas effacées, mais sont copiées de nouveau en dessous^^ je pense que quelques modifications sont à faire!!

Je joints le code que j'ai essayé en question :

Option Explicit

Sub dispatching()
Dim i, lg As Integer
Dim ShS, ShD, ShE As Worksheet

Set ShS = Sheets("saisie")
Set ShD = Sheets("publi simple")
Set ShE = Sheets("publi multiple")
'effacement des données presente dans la feuille publisimple
If ShD.Cells(Rows.Count, "A").End(xlUp).Row > 1 Then ShD.Range("A2:N" & ShD.Cells(Rows.Count, "A").End(xlUp).Row).ClearContents
If ShE.Cells(Rows.Count, "A").End(xlUp).Row > 1 Then ShD.Range("A2:H" & ShE.Cells(Rows.Count, "A").End(xlUp).Row).ClearContents
    For i = 7 To ShS.Cells(Rows.Count, "P").End(xlUp).Row
If ShS.Cells(i, "P") = "publipostage simple" Then
    lg = ShD.Cells(Rows.Count, "A").End(xlUp).Row + 1
    ShS.Range(ShS.Cells(i, "A"), ShS.Cells(i, "F")).Copy ShD.Cells(lg, "A")
    ShS.Range(ShS.Cells(i, "H"), ShS.Cells(i, "H")).Copy ShD.Cells(lg, "G")
    ShS.Range(ShS.Cells(i, "J"), ShS.Cells(i, "O")).Copy ShD.Cells(lg, "H")
End If
    If ShS.Cells(i, "P") = "publipostage multiple" Then
    lg = ShE.Cells(Rows.Count, "A").End(xlUp).Row + 1
    ShS.Range(ShS.Cells(i, "A"), ShS.Cells(i, "B")).Copy ShE.Cells(lg, "A")
    ShS.Range(ShS.Cells(i, "J"), ShS.Cells(i, "O")).Copy ShE.Cells(lg, "C")
End If
Next
'efface les bordures
ShE.Range("A2:H" & ShE.Cells(Rows.Count, "A").End(xlUp).Row).Borders.LineStyle = xlNone
ShD.Range("A2:N" & ShD.Cells(Rows.Count, "A").End(xlUp).Row).Borders.LineStyle = xlNone

End Sub

En ce qui concerne le passage des valeurs selon le format souhaité, heu.... j'ai pas d'idée et surtout je ne sais pas comment l'insérer au milieu de tout ça??

J'ai en ma possession une macro qui fait cela ( cf. autre post du forum et un grand merci à Frangy en passant )

Je joints la macro en question en espérant que cela puisse t'aider et diminuer la charge de boulot!!

Option Explicit
Sub Test()
Dim WsS As Worksheet, WsC As Worksheet
Dim Cel As Range
Dim Texte As String
Dim T
    Set WsS = Worksheets("Feuil1")
    Set WsC = Worksheets("Feuil2")
    For Each Cel In WsS.Range("A2:A" & WsS.Range("A" & Rows.Count).End(xlUp).Row)
        Texte = Texte & Cel & " " & Cel.Offset(, 1) & ", "
    Next Cel
    WsC.Range("A2") = Left(Texte, Len(Texte) - 2)
    WsC.Range("B2") = WsS.Range("C2")
    WsC.Range("C2") = WsS.Range("D2")
    WsC.Range("D2") = WsS.Range("E2")
    WsC.Range("E2") = WsS.Range("F2")
    WsC.Activate
    Set WsC = Nothing: Set WsS = Nothing
End Sub

Merci pour l'aide futur et bonne journée...

Bonsoir

pas eut le temps de regardé cela aujourd'hui

si tout vas bien je regarde cela demain

fred

Bonsoir,

Merci pour votre réponse, pas de soucis c'est sympa de votre part.

Bonne soirée.

Bonsoir

un essai pour un dispatch multiple

a tester

fred

Sub dispatching_multiple()
Dim i, lg As Integer
Dim ShS, ShD As Worksheet
Dim compil As String

Set ShS = Sheets("saisie")
Set ShD = Sheets("publi multiple")
'effacement des données presente dans la feuille publisimple
If ShD.Cells(Rows.Count, "A").End(xlUp).Row > 1 Then ShD.Range("A2:H" & ShD.Cells(Rows.Count, "A").End(xlUp).Row).ClearContents
For i = 7 To ShS.Cells(Rows.Count, "P").End(xlUp).Row
    If ShS.Cells(i, "P") = "publipostage multiple" Then
        If compil = "" Then lg = ShD.Cells(Rows.Count, "B").End(xlUp).Row + 1
        If ShD.Cells(lg, "B") = "" Then
        ShS.Range(ShS.Cells(i, "J"), ShS.Cells(i, "O")).Copy
        ShD.Cells(lg, "B").PasteSpecial Paste:=xlPasteValues
        ShD.Cells(lg, "H") = ShS.[C3].Value
        End If
        compil = compil & ShS.Cells(i, "A").Value & " " & ShS.Cells(i, "B").Value & ", "
    End If
    If ShS.Cells(i, "P").Interior.Color = 49407 And compil <> "" Then
        compil = Left(compil, Len(compil) - 2)
        ShD.Cells(lg, "A") = compil
        compil = ""
    End If
Next
'efface les bordures
ShD.Range("A2:H" & ShD.Cells(Rows.Count, "A").End(xlUp).Row).Borders.LineStyle = xlNone
End Sub

Bonjour Fred,

Un grand merci pour le retour sur la macro de publi multiple -> au top, fait exactement le boulot souhaité!!

J'aurais juste une dernière petite demande : elle concerne la macro sur le publipostage : serait-il possible à la fin d'avoir un message qui demande si l'on souhaite ou pas l'impression des publipostages générés en pdf? Et en cas de réponse positive, lancer une impression via l'imprimante par défaut du PC?

Dans l'attente d'un retour.

Bonne journée et un grand merci d'avance.

bonjour

oui cela est possible redonne moi le lien ou le code pour la macro publipostage que j'ai fait

merci

fred

Re bonjour

j'ai un peu de mal a me remettre dans le publipostage que j'ai fait.... avec le fichier modele , le fichier source....

je te propose ceci :

a mettre a la fin du code de publipostage juste avant le end sub :

If MsgBox("Voulez-vous imprimer les pdf générés ?", vbExclamation + vbYesNo) = vbYes Then imprimer_PDF (cheminW)

et dans un nouveau module :

Option Explicit
'impression pdf compatible office 32 et 64 bits
'http://forum.excel-pratique.com/excel/imprimer-un-fichier-pdf-depuis-une-commande-excel-t15664.html

' Test which version of VBA you are using.
#If VBA7 Then
   ' API function to locate a window.
  Declare PtrSafe Function FindWindow Lib "user32" _
      Alias "FindWindowA" ( _
      ByVal lpClassName As String, _
      ByVal lpWindowName As String) As LongPtr

    Private Declare PtrSafe Function ShellExecute Lib _
        "shell32.dll" Alias "ShellExecuteA" ( _
        ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, _
        ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
#Else
   ' API function to locate a window.
  Declare Function FindWindow Lib "user32" _
      Alias "FindWindowA" ( _
        ByVal lpClassName As String, _
            ByVal lpWindowName As String) As Long

    Private Declare Function ShellExecute Lib _
        "shell32.dll" Alias "ShellExecuteA" ( _
            ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
                ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If

Sub imprimer_PDF(chemin As String)
    Dim Fso As Object
    Dim SourceFolder As Object
    Dim FileItem As Object
    Dim fichier_en_traitement As String
    'chemin = ThisWorkbook.Path & "\"
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = Fso.GetFolder(chemin)
    'Boucle sur tous les fichiers du répertoire
    For Each FileItem In SourceFolder.Files
            If Right(FileItem.Name, 4) = ".pdf" Then Imprimer (chemin & FileItem.Name)                ' on recupere le nom du fichier
    Next FileItem
End Sub
Sub Imprimer(NomFichier As String)
    'Dim NomFichier As String
    Dim x As Long
    x = FindWindow("XLMAIN", Application.Caption)
    ShellExecute x, "print", NomFichier, "", "", 1
End Sub

cela va imprimer les pdf présent tous les pdf présents dans le dossier contenant le fichier qui fait le publipostage

fred

Rechercher des sujets similaires à "macro creation publipostage"