Filtration valeur et Envoi email

Le 11/12/2024 à 20:33

Bonjour à tous,

Je me permets de vous demandez votre aide concernant un code VBA pour mon fichier que je n'arrive pas à trouver 😢

J'ai un fichier Excel de suivi journalière d'activité qui s'agrandit tout les jours contenant une colonne n°sem (colonne A) et du détails.

N°semDateProjetDétailsTemps
101/01/24AaaCcc1
208/01/24AaaTtt2
209/01/24RrrYyy5
316/01/24AaaaIii1
316/01/24rrrOoo3
Etc..

Mon besoin est suite à une saisie de valeur dans une Inputbox (exemple : 2), la valeur de la ligne "1"(titre) et la liste des données contenant la valeur saisie dans la première colonne .

Exemple Résultats souhaités :

N°semDateProjetDétailsTemps
208/01/24AaaTtt2
209/01/24RrrYyy5

Et envoyer ce résultat par mail.

Pouvez vous m'aider pour la création du code?

Je vous remercie

Le 12/12/2024 à 13:44

Bonjour,

Voici une proposition de solution

J'espère que ça répond à la question

Bonne journée,

12max59.xlsm (21.18 Ko)
Le 13/12/2024 à 08:07

Bonjour Boshupp,

Merci pour ce retour.

Mon besoin ( désolé je viens de remarquer que je l'avais pas indiquer) et d’insérer le résultat dans le corps de l'email.

Le 13/12/2024 à 10:07

Bonjour à tous,

En reprenant le code de @Boshupp et une fonction trouvée ici : Convert Excel Range Into HTML Table Through VBA 2024

Le fichier ci-joint devrait fonctionner. Pour envoyer automatiquement le mail, dans le code VBA retirer le commentaire sur .Send.

Ci-après le code complet du module et le fichier.

9max59.xlsm (23.93 Ko)
Sub filtrage()
  Dim ws As Worksheet
  Dim valeur As String
  Dim plage As Range
  Dim colonne As Long

  Dim OutlookApp As Object
  Dim OutlookMail As Object
  Dim CheminFichier As String

  ' D�finir la feuille de travail
  Set ws = ThisWorkbook.Sheets("Feuil1")

  ' Sp�cifiez la valeur � rechercher
  valeur = ws.Range("J4")

  ' Sp�cifiez la colonne � filtrer
  colonne = 1

  ' D�finir la plage � filtrer (ici de la ligne 2 � la ligne 100)
  Set plage = ws.Range("A1:E100")

  ' Appliquer le filtre
  ws.AutoFilterMode = False                      ' D�sactiver les filtres existants
  plage.AutoFilter Field:=colonne, Criteria1:=valeur ' Filtrer en fonction de la valeur

  If ws.Range("J4") = "" Then
    ws.AutoFilterMode = False
  End If

  ' Cr�er une instance de l'application Outlook
  Set OutlookApp = CreateObject("Outlook.Application")
  Set OutlookMail = OutlookApp.CreateItem(0)     ' 0 correspond � un email

  ' Créer l'email
  With OutlookMail
    .To = "example@email.com"                    ' L'adresse email du destinataire
    .Subject = "Objet de votre email"
    .HTMLBody = "<body> <p>Voici la feuille Excel demandée.</p>" ' Corps du message
    .HTMLBody = .HTMLBody & RngToHTMLTable(Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)) ' tableau
    .HTMLBody = .HTMLBody & "</body>" ' fin
    .Display                          ' afficher l'email avant envoi
    '.Send                                        ' Envoyer l'email
  End With

  ' Lib�rer les objets
  Set OutlookMail = Nothing
  Set OutlookApp = Nothing

End Sub

'Following function converts Excel range to HTML table
'https://www.excelsirji.com/vba-code-to-convert-excel-range-into-html-table/
Private Function RngToHTMLTable(rInput As Range) As String
  'Declare variables
  Dim rRow As Range
  Dim rCell As Range
  Dim strReturn As String
  'Define table format and font
  strReturn = "<Table border='1' cellspacing='0' cellpadding='7' style='border-collapse:collapse;border:none'> "
  'Loop through each row in the range
  For Each rRow In rInput.Rows
    'Start new html row
    strReturn = strReturn & " <tr align='Center'; style='height:10.00pt'> "
    For Each rCell In rRow.Cells
      'If it is row 1 then it is header row that need to be bold
      If rCell.Row = 1 Then
        strReturn = strReturn & "<td valign='Center' style='border:solid " _
                  & "windowtext 1.0pt; padding:0cm 5.4pt 0cm 5.4pt;height:1.05pt'><b>" & rCell.Text & "</b></td>"
      Else
        strReturn = strReturn & "<td valign='Center' style='border:solid " _
                  & "windowtext 1.0pt; padding:0cm 5.4pt 0cm 5.4pt;height:1.05pt'>" & rCell.Text & "</td>"
      End If
    Next rCell
    'End a row
    strReturn = strReturn & "</tr>"
  Next rRow
  'Close the font tag
  strReturn = strReturn & "</font></table>"
  'Return html format
  RngToHTMLTable = strReturn
End Function
Le 13/12/2024 à 11:32

Oh TOP!!! 👌

Merci Beaucoup

Le 13/12/2024 à 11:42

Merci pour votre retour. Bonne journée.

Rechercher des sujets similaires à "filtration valeur envoi email"