Recherche de contenu de cellule et affectation
Bonjour,
Je débute en VBA sous excel. Je suis à la recherche d'une méthode qui me permettrait d'affecter à une variable vba (dans un macro) des valeurs trouvées dans un feuille en fonction de la valeur de la première colonne. En fait, je cherche à affecter des adresses email disposées en ligne en fonction de la valeur d'une cellule (modifiable par l'utilisateur. En l'occurrence, le numéro du département concerné.
Les données sont : Première colonne A : département (valeur de recherche). 2ème B, 3ème C et 4 ème D colonnes contiennent les courriels des personnes destinataires.
Les variables sont ensuite destinées à composer une macro qui prépare un courriel sous thunderbird préparé avec un pièce jointe. Cette partie fonctionne déjà très bien. J'ai besoin d'aide en fait pour la partie recherche et stockage des adresses de courriel dans un variable en fonction d'une cellule. Les destinataires du courriel à envoyer doivent correspondre à la ligne du département concerné.
Je remercie par avance ceux d'entre vous qui auront pu prendre le temps d'examiner ma demande et de m'apporter une aide bienvenue !
LP
Bonjour Laurent67
Une petite fonction personnalisée que j'utilise
Public Function vFindR(sFeuil As String, sCol As String, Quoi As String, ColR As String)
Dim LigFind As Long
' sFeuil = nom de la feuille dans laquelle chercher
' sCol = Colonne dans laquelle chercher
' Quoi = Valeur à chercher
' ColR = Colonne de retour de la valeur
VFindR = "": LigFind = 0
' Effectue la recherche
On Error Resume Next
With Sheets(sFeuil).Range(sCol & ":" & sCol)
LigFind = .Find(What:=Quoi, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
MatchCase:=False, SearchFormat:=False).Row
If Err.Number = 0 Then
VFindR = Sheets(sFeuil).Range(ColR & LigFind).Value
Else
VFindR = ""
End If
End With
' Gestion normale des erreurs
On Error GoTo 0
End Function
Pour avoir tes adresses mails, tu fais
AdrMail1 = vFindR("FeuilleDeDonnées","A",NuméroDépartement,"B")
AdrMail2 = vFindR("FeuilleDeDonnées","A",NuméroDépartement,"C")
' Etc...
A+
C'est relativement complexe. Je vais essayer de décoder...
Merci pour votre réponse !
Re,
Non, rassure toi il n'y a rien de complexe
Tu as juste à mettre la fonction à la fin de ton module
Et pour avoir les adresses mail, il suffit d'appeler la fonction comme je l'ai décrit
Donne nous ton code entier et je te remets tout ça en place
A+
Merci pour ta réponse. Difficile de déposer ma feuille sur le forum car les données internes.
Mais voici le descriptif des données :
La feuille : tout est dans "Feuil1"
Cellule contenant la valeur à rechercher : B2 (un numéro de département)
Plage contenant les département :
B9 à B19
Le numéro étant trouvé, sur la ligne correspondant au département recherché, il y a l'adresse des 5 correspondants destinataires du courriel (colonnes C à G).
Ce que je souhaiterais, c'est que la macro aille cherche la bonne ligne en fonction de la valeur du département (B9 à B19) et range les cinq adresses de courriel dans une variable : destinataire = "adresse1,adresse2,adresse3"
Merci pour ton aide
add_ref01 add_ref02 add_ref03 addr_dir_1 addr_dir_2
08
10
51
52
54
55
57
67
68
88
Sub envoi_mail_auto()
Dim fichier As String
Dim Mondossier As String
Mondossier = "D:\Utilisateurs\laurent\Documents\test_mail\"
With Worksheets("Feuil1")
fichier = "\Consommations_TEST_" & "_2019.pdf"
Dossier = "D:\Utilisateurs\laurent\Documents\test_mail\"
Chemin = Dossier & fichier
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
If MsgBox("Le fichier : \Consommations_fin_2019.pdf a été créé dans le répertoire :" & Chr(13) & "P:\SUIVI_2019\Envois situations PDF aux clients" & Chr(13) & Chr(13) & "Préparer l'envoi? ", vbYesNo, "Création du PDF") = vbYes Then Call envoi_dd
End With
End Sub
Re,
Le code donné n'est pas celui d'envoi du mail
C'est celui ou tu fais partir ton mail qui m'intéresse
Ce doit être "Call envoi_dd"
A+
Sub envoi_dd()
Dim destinataire, sujet, fichierjoint As String
destinataire = "toto@orange.fr,tata@orange.fr" (c'est là que je voudrais intégrer les adresses des destinataires)
sujet = "Situation financière "
body = "Veuillez trouver ci-joint la situation budgétaire"
fichierjoint = "D:\Utilisateurs\laurent\Documents\test_mail\Consommations_2019.pdf"
' strcommand = "C:\Program Files\Mozilla Thunderbird\thunderbird"
strcommand = "C:\Program Files (x86)\Thunderbird\thunderbird.exe"
strcommand = strcommand & " -compose " & "to='" & Address & "'"
' strcommand = strcommand & " -compose " & "to='" & destinataire & "'"
strcommand = strcommand & "," & "subject=" & sujet & ","
strcommand = strcommand & "body=" & body
strcommand = strcommand & "," & "attachment=file:///" & fichierjoint
' MsgBox "test" & strcommand
Call Shell(strcommand, vbNormalFocus)
End Sub
Re,
Voici le code un peu modifier pour que ce soit plus simple côté fonction
Option Explicit
Sub Envoi_DD()
Dim Body As String, Sujet As String, FichierJoint As String
Dim Destinataire As String, StrCommand As String
Dim Col As Long, LigF As Long, DesTmp As String
Dim NumDept As String
' Récupérer le numéro de département
NumDept = Sheets("Feuil1").Range("B2").Value
LigF = LigFind("Feuil1", "B9:B19", NumDept)
If LigF = 0 Then
MsgBox "Erreur pour trouver la ligne !", vbCritical, "OUPS..."
Exit Sub
End If
' Pour chaque colonne ajouter le destinataire
For Col = 3 To 7 ' Colonne 3=C à 7=G
DesTmp = Sheets("Feuil1").Cells(LigF, Col)
If DesTmp <> "" Then
If Destinataire = "" Then
Destinataire = DesTmp & ","
Else
Destinataire = Destinataire & DesTmp & ","
End If
End If
Next Col
' Supprimer la dernière virgule qui ne sert à rien
Destinataire = Left(Destinataire, Len(Destinataire) - 1)
' Préparer le mail
Sujet = "Situation financière "
Body = "Veuillez trouver ci-joint la situation budgétaire"
FichierJoint = "D:\Utilisateurs\laurent\Documents\test_mail\Consommations_2019.pdf"
' Préparer la commande d'envoi mail par Thunderbird
StrCommand = "C:\Program Files (x86)\Thunderbird\thunderbird.exe"
' Ou peut-être !?
StrCommand = "C:\Program Files (x86)\Mozilla Thunderbird\thunderbird.exe"
'strcommand = strcommand & " -compose " & "to='" & Address & "'"
StrCommand = StrCommand & " -compose " & "to='" & Destinataire & "'"
StrCommand = StrCommand & "," & "subject=" & Sujet & ","
StrCommand = StrCommand & "body=" & Body
StrCommand = StrCommand & "," & "attachment=file:///" & FichierJoint
' MsgBox "test" & strcommand
Call Shell(StrCommand, vbNormalFocus)
End Sub
' Fcontion plus simple, pour juste trouver la ligne correspondante
Function LigFind(sFeuil As String, sPlgSearch As String, Quoi As String)
' sFeuil = Nom de la feuille dans laquelle chercher
' sPlgSearch = Nom de la plage de recherche
' Quoi = Valeur à chercher
'
' Effectue la recherche
On Error Resume Next
With Sheets(sFeuil).Range(sPlgSearch)
' Initialiser le numéro de ligne
LigFind = 0
LigFind = .Find(What:=Quoi, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
MatchCase:=False, SearchFormat:=False).Row
End With
' Gestion normale des erreurs
On Error GoTo 0
End Function
A+
Bonjour,
Merci pour ton aide. Je viens de tester le code.
J'ai une erreur de compilation
"Sub ou fonction non définie"
sur la ligne : LigF = LigFind("Feuil1", "B9:B19", NumDept)
Pensant que Ligfind est une variable, je l'ai définie (Dim as string) mais ça ne change rien.
As-tu une idée ?
Merci et bonne journée.
Cordialement,
Laurent
Re,
Je t'ai mis le code testé qu'il faut remplacer, maintenant si tu veux faire à ta sauce... débrouille toi
Re,
Non pas du tout. Je cherche à comprendre. Je crois que je n'ai pas su copier le code au bon endroit, tout simplement.
Dans un nouveau module, je suppose.
Je vais essayer de comprendre. Merci encore pour ton aide et le temps que tu as consacré à m'aider.
Cordialement,
LP
Re,
Je viens de terminer la reprise du code.
Mes envois de courriels fonctionnent parfaitement.
Merci pour ton coup de main !
Cordialement,
LP