Recherche de contenu de cellule et affectation

Le 25/03/2019 à 13:19

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 !

Le 25/03/2019 à 13:27

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+

Le 25/03/2019 à 14:42

C'est relativement complexe. Je vais essayer de décoder...

Merci pour votre réponse !

Le 25/03/2019 à 14:45

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+

Le 25/03/2019 à 16:44

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

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

Le 25/03/2019 à 16:57

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+

Le 25/03/2019 à 17:12

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

Le 25/03/2019 à 18:08

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+

Le 26/03/2019 à 10:47

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