Mail avec extrait Excel

Bonjour,

j'essaye un max de me débrouiller seul mais là je suis sur un os:

La fonction que j'essaye de faire:

• Filtrer un tableau
• copier données filtrées dans un autre onglet (de travail)
• copier ces données
• ouvrir un mail et coller ces données (HTML)

le code fonctionne (transformer en HTML puis coller dans un mail vierge etc).

Le problème est le suivant: dans le mail je me retrouve avec plein de lignes vierges en dessous du tableau que je veux. J'ai beau essayer d'effacer ces lignes avant qu'il ne les copie dans un mail, pas moyen...

des idées? (désolé mais pour la redondance d'effectif, je suis obligé de travailler en anglais au boulot)

un grand merci !

voici le code:

'Following function converts Excel range to HTML table
Public Function ConvertRangeToHTMLTable(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='right'; 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
ConvertRangeToHTMLTable = strReturn
End Function
------------------------------------
'This function creates an email in Outlook and call the ConvertRangeToHTMLTable function to add Excel range as HTML table in Email body
Sub CreateOutlookEmail()

Dim rng As Range
'clean temp sheet
Sheets("Devis").Select
Sheets("TempMail").Visible = True
Sheets("TempMail").Select
Cells.Select
Selection.Clear
Range("A1").Select

'apply filetr to data and copy relevant data
Sheets("Devis").Select
ActiveSheet.Range("$A$1:$G$65").AutoFilter Field:=5, Criteria1:="<>"
Range("B:F").SpecialCells(xlCellTypeVisible).Select
Selection.Copy

'paste relevant data to temp sheet
Sheets("TempMail").Select
Range("A1").Select
ActiveSheet.Paste
'try to erase empty rows under the table
Set rng = Range("A1:E100").SpecialCells(xlCellTypeBlanks)
rng.EntireRow.Delete

Range("G1").Select

're-hide temp sheet and return to Devis sheet
Sheets("TempMail").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Devis").Select
Range("I5").Select
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$G$65").AutoFilter Field:=5
Range("I1").Select

'Declare variable
Dim objMail As Outlook.MailItem
'Create new Outlook email object
Set objMail = Outlook.CreateItem(olMailItem)
'Assign To
objMail.To = "test@gmail.com"
'Assign Cc
objMail.CC = "test2@gmail.com"
'Assign Subject
objMail.Subject = "Test Email"
'Define HTML email body
'Tip: Here i have converted range A1:F20 of Sheet1 in HTML table, you can modify the same as per your requirement
objMail.HTMLBody = "<P><font size='2' face='Calibri' color='black'>This is a test email</font></P>" & ConvertRangeToHTMLTable(Sheet8.Range("A1:E" & Range("A1").End(xlDown).Row))
objMail.HTMLBody = "<P><font size='2' face='Calibri' color='black'>This is a test email</font></P>" & ConvertRangeToHTMLTable(Sheet8.Range("A1:E" & Range("A1").End(xlDown).Row))
'Show the email to User
objMail.Display
'Send the email
'objMail.Send
'Close the object
Set objMail = Nothing
End Sub

Bonjour,

Dans ta fonction "ConvertRangeToHTMLTable", il ne faut pas que "rRow" soit utilisé si ses valeurs sont vides donc

'Loop through each row in the range
For Each rRow In rInput.Rows
     If rRow.Value2(1, 1) = "" Then GoTo NextrRow

..........

NextrRow:
Next rRow

Fourni un fichier exemple la prochaine fois

Sans cette ligne :

Avec cette ligne :

A+

Bonjour Geof,

Soyez béni par les dieux de Excel ! Merci bcp pour votre aide, je n'avais pas tiqué que le problème venait de cette fonction !

Simple précision, je vois que vous avez apporté d'autres modifications au code, simplement pour faire plus propre ou ça apporte réellement quelque chose?

J'essaye chaque fois d'apprendre les bonnes pratiques grâce à des personnes comme vous.

Encore merci cela m'enlève une épine du pied.

Excellente journée

J'ai changé cette partie :

'Create new Outlook email object
Set objMail = Outlook.CreateItem(olMailItem)

qui ne fonctionne pas si certaines references Outlook sont manquante, en :

'Create new Outlook email object
Set objApp = CreateObject("Outlook.Application")
Set objMail = objApp.CreateItem(0)

D'ailleurs j'ai oublié :

Set objApp = Nothing

a la fin de la macro.

_______________________________________________

J'ai aussi supprimé le doublon de la ligne :

objMail.HTMLBody = "<P><font size='2' face='Calibri' color='black'>This is a test email</font></P>" & ConvertRangeToHTMLTable(Sheets("TempMail").Range("A1:E" & Cells(Rows.Count, 1).End(xlUp).Row))

Qui sert a rien
et modifié dans cette meme ligne le "Sheet8" qui dépend de ton fichier en "Sheets("TempMail")" (qui sera toujours vrai)
et toujours dans cette ligne compter la derniere ligne de la colonne 1 = Cells(Rows.Count, 1).End(xlUp).Row

Bonne journée

C'est super gentil de m'avoir expliqué !

J'ai appris plein de choses et je vous en remercie.

Excellente journée