Generer automatiquement des releves et envoyer a differents destinataires
Bonjour
J'essaie depuis quelques jours de mettre en place une macro me permettant de créer un relevé de factures clients se trouvant dans ma feuille base vente,avec les coordonnées des differents clients dans la feuille base clients,afin qu'ils vérifient qu'ils ont bien reçu toutes les factures à payer prochainement. Je voudrais qu'avecun bouton chaque fichier client soit généré et envoyé à la bonne adresse mail via outlook, mais il ya des erreurs
Sub RELEVE()
'
' RELEVE Macro
'
Dim Intitule As String
' demande de confirmation
Sheets("PARAMETRES").Select
PDFlocation = Range("B1").Value
Sheets("BASE DONNES CLIENTS").Select
Rep = MsgBox("Voulez-vous continuez ?", vbYesNo + vbQuestion, "Génération des Relevés dans le dossier " & PDFlocation)
If Rep = vbNo Then
' si non est repondu on sort de la macro
Exit Sub
End If
' Nb Lignes
nb_Lignes = Application.WorksheetFunction.CountA(Range("$A:$A"))
'Faire pour toutes les lignes
For ligne_active_base = 2 To nb_Lignes
'Nom du Client
Sheets("BASE DONNES CLIENTS").Select
' ligne_active_base = ActiveCell.Row
'Chercher l'intitulé en cours de traitement
Intitule = Range("C" & ligne_active_base).Value
Range("C" & ligne_active_base).Select
Selection.Copy
Sheets("RELEVE-TEMPLETE").Select
Range("E9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Adresse
Sheets("BASE DONNES CLIENTS").Select
Range("D" & ligne_active_base).Select
Selection.Copy
Sheets("RELEVE-TEMPLETE").Select
Range("E10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Code postal
Sheets("BASE DONNES CLIENTS").Select
Range("E" & ligne_active_base).Select
Selection.Copy
Sheets("RELEVE-TEMPLETE").Select
Range("E11").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'remise a blanc des zones du relevé
Sheets("RELEVE-TEMPLETE").Select
Range("A27:F150").ClearContents
' remettre a zéro le total
TotalRelevé = 0
' Se positionner dans Base Ventes
Sheets("BASE VENTES").Select
' Rechercher les factures dans la feuille "BASE VENTES" pour ce client (lien par intitulé)
' Le lien se fait sur l'intitulé du compte
OutLigne = 27
' recheche de la première facture
Posligne = Application.Match(Intitule, Range("H1:H20000"), 0)
' Si rien n'ext trouvé on arrête
If IsError(Posligne) Then GoTo PDF
' If IsError(PosLigne) Then MsgBox "valeur non trouvée"
' si le l'intitulé n'est pas le même on continu a chercher
If (Intitule <> Range("H" & Posligne).Value) Then GoTo IGNORE
RELEVE:
Range("A2").Select
ActiveCell.FormulaR1C1 = Retour
' si on trouve: on place le numéro de relevé en position A27
Sheets("BASE VENTES").Select
Range("D" & Posligne).Select
Selection.Copy
Sheets("RELEVE-TEMPLETE").Select
Range("A" & OutLigne).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Date Facture
Sheets("BASE VENTES").Select
Range("B" & Posligne).Select
Selection.Copy
Sheets("RELEVE-TEMPLETE").Select
Range("B" & OutLigne).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Date Echéance
Sheets("BASE VENTES").Select
Range("K" & Posligne).Select
Selection.Copy
Sheets("RELEVE-TEMPLETE").Select
Range("D" & OutLigne).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Montant
Sheets("BASE VENTES").Select
Range("R" & Posligne).Select
Selection.Copy
Sheets("RELEVE-TEMPLETE").Select
Range("F" & OutLigne).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Chercher le total de la facture
ValueFacture = Range("F" & OutLigne).Value
'Calculer le total du relevé
TotalRelevé = TotalRelevé + ValueFacture
' On augmente le numéro de ligne
OutLigne = OutLigne + 1
Sheets("BASE VENTES").Select
IGNORE:
RunLigne = Posligne + 1
Posligne = Application.Match(Intitule, Range("H" & RunLigne & ":H20000"), 0)
' Si rien n'ext trouvé on arrête
If IsError(Posligne) Then GoTo PDF
Posligne = Posligne + RunLigne - 1
' tant que l'intitule est identique on continu
If (Intitule = Range("H" & Posligne).Value) Then GoTo RELEVE
' si on a trouve mais l'intitule n'est pas le même (un intitulé e contient un autre)
GoTo IGNORE
PDF:
' Ajouter le total
Sheets("RELEVE-TEMPLETE").Select
Range("E" & OutLigne + 1).Select
ActiveCell.FormulaR1C1 = "Total"
Range("F" & OutLigne + 1).Select
ActiveCell.FormulaR1C1 = TotalRelevé
' ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
' IgnorePrintAreas:=False, Preview:=True
' Range("G4").Select
' rechercher l'emplacement du fichier PDF
Sheets("PARAMETRES").Select
PDFlocation = Range("B1").Value
Range("C:\0DOSSIER CHARLOTTE").ExportAsFixedFormat Type:=xlTypePDF, Filename:="0DOSSIER CHARLOTTE & Intitule & ".pdf"
' passez à la ligne suivante
Next
Sheets("BASE DONNES CLIENTS").Select
End Sub
Sub Envoid_des_Emails()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
'Set OutApp = CreateObject("Outlook.Application")
'Set OutMail = OutApp.CreateItem(0)
Sheets("PARAMETRES").Select
PDFlocation = Range("C:\0DOSSIER CHARLOTTE").Value
Range("C:").Select
Rep = MsgBox("Voulez-vous continuez ?", vbYesNo + vbQuestion, "Envoie des Emails avec PDF depuis " & PDFlocation)
If Rep = vbNo Then
' si non est repondu on sort de la macro
Exit Sub
End If
' Nb Lignes
nb_Lignes = Application.WorksheetFunction.CountA(Range("$A:$A"))
For ligne_active_base = 2 To nb_Lignes
'Chercher l'intitulé en cours de traitement
Intitule = Range("C" & ligne_active_base).Value
EmailTo = Range("H" & ligne_active_base).Value
strbody = Contenu
Set OutApp = CreateObject("outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "sikaahoua@outlook.com"
.CC = ""
.Subject = "Releve mensuel: " & Intitule
.Body = "veuillez trouver ci joint"
'Piece_jointe
.Attachments.Add (PDFlocation & Intitule & ".pdf")
.Send
'.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
Next
End Sub
Bonjour,
La lecture et la compréhension du code est rendue difficile à cause du faire qu'il soit "sale", en clair une bonne partie du code a été faite via l'enregistreur de macro, ce qui laisse énormément de lignes de codes qui peuvent être remplacées par quelque chose de plus compact, j'ai commencé à faire ça dans le fichier:
Là où j'ai plus de mal à comprendre et donc à "nettoyer", c'est toutes les parties avec les Goto que tu as dans ton code, je dois avouer ne pas très bien comprendre leurs logiques, j'aurais peut-être besoin de quelques explications...
Si tu te demandes pourquoi je souhaite au préalable faire ça, c'est que tu nous as posté un code difficile à lire et donc difficile à corriger, je souhaite donc le transformer en quelque chose de plus compact et plus structuré pour pouvoir ensuite l'analyser, c'est une tâche que nous n'aimons pas trop faire mais qui est ici importante pour t'aider, j'espère que tu pourras m'aider à le faire
Merci pour ta réponse, en fait les GoTo ça serait pour aller à la ligne suivante quand il ne trouve plus de factures concernant le client, ou plus de clients du tout, je ne sais pas si c'est la réponse attendue
Re,
Donc si je comprends bien, le but initial de la macro, c'est de faire la feuille releve automatiquement, pour ça tu dois envoyer un mail de récapitulatif à chacun de tes clients dans BASE CLIENT, en allant chercher dans les factures, les différentes factures qui ont été faites pour lui, en liant les 2 tableaux avec le compte. tu extrais ensuite toutes les infos des factures, fais le total, exporte la feuille en pdf, pour plus tard l'envoyer (chose que gère un autre programme), c'est ça?
Parce que dans ta macro je ne vois pas du tout le critère de date...
Si c'est bien ça que tu veux faire, je dois pouvoir te refaire un programme en repartant de 0 qui sera plus clair