Erreur Compilation : Sub ou fonction non définie
Bonjour,
J'ai un problème dans ma macro avec le message Erreur compilation : Sub ou fonction non définie
le problème est sur RangetoHTML(rng) que j'ai sous ligné, mis en gras et en jaune plus bas. Ce que je ne comprends pas c'est que j'ai déjà fait la même macro et je n'avais aucun soucis ;(.
Merci pour votre aide !
Voici la macro :
Sub PURGELIST()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Working in Excel 2000-2016
Dim sh, sh1, sh2, sh3 As Worksheet
Dim wb As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim rng As Range
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFilePath = Environ$("temp") & "\"
'Determine la version Excel et le type de fichier/format
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsm": FileFormatNum = 52
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set OutApp = CreateObject("Outlook.Application")
'Si l'Username en cellule B1 à une correspondance Username dans l'onglet "Mapping" si non erreur
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> "TCD CONSO" And sh.Name <> "DATABASE" And sh.Name <> "Mapping" And sh.Name <> "TEST" And sh.Name <> "Setting" And sh.Name <> "(vide)" _
And sh.Name <> "887" And sh.Name <> "899" And sh.Name <> "847" And sh.Name <> "870" And sh.Name <> "95F" And sh.Name <> "95E" _
And sh.Name <> "95C" And sh.Name <> "DD" And sh.Name <> "AD" And sh.Name <> "CD" And sh.Name <> "EL" And sh.Name <> "FD" And sh.Name <> "M2" Then
For Each sh1 In ThisWorkbook.Worksheets
If sh1.Name <> "TCD CONSO" And sh1.Name <> "DATABASE" And sh1.Name <> "Mapping" And sh1.Name <> "TEST" And sh1.Name <> "Setting" And sh1.Name <> "(vide)" _
And sh1.Name <> "887" And sh1.Name <> "899" And sh1.Name <> "847" And sh1.Name <> "870" And sh1.Name <> "95F" And sh1.Name <> "95E" _
And sh1.Name <> "95C" And sh1.Name <> "DD" And sh1.Name <> "AD" And sh1.Name <> "CD" And sh1.Name <> "EL" And sh1.Name <> "FD" And sh1.Name <> "M2" Then
If Application.Worksh1eetFunction.CountIf(ThisWorkbook.Sheets("Mapping").Range("A:B"), sh1.Range("J9").Value) = 0 Then
MsgBox sh1.Name & " Username" & " not fill out in mapping tab 1" & vbLf & vbLf & _
" Please correct and try again. ", vbOKOnly + vbExclamation
Exit Sub
End If
End If
Next sh1
For Each sh2 In ThisWorkbook.Worksheets
If sh2.Name <> "TCD CONSO" And sh2.Name <> "DATABASE" And sh2.Name <> "Mapping" And sh2.Name <> "TEST" And sh2.Name <> "Setting" And sh2.Name <> "(vide)" _
And sh2.Name <> "887" And sh2.Name <> "899" And sh2.Name <> "847" And sh2.Name <> "870" And sh2.Name <> "95F" And sh2.Name <> "95E" _
And sh2.Name <> "95C" And sh2.Name <> "DD" And sh2.Name <> "AD" And sh2.Name <> "CD" And sh2.Name <> "EL" And sh2.Name <> "FD" And sh2.Name <> "M2" Then
If Application.WorksheetFunction.VLookup(sh2.Range("J9").Value, ThisWorkbook.Sheets("Mapping").Range("A:E"), 5, False) Like "" Then
MsgBox sh2.Name & " Email" & " not fill out in mapping tab2" & vbLf & vbLf & _
" Please correct and try again. ", vbOKOnly + vbExclamation
Exit Sub
End If
End If
Next sh2
'Si la valeur en cellule B1 à une correspondance mail dans l'onglet "Mapping" si non erreur
For Each sh3 In ThisWorkbook.Worksheets
If sh3.Name <> "TCD CONSO" And sh3.Name <> "DATABASE" And sh3.Name <> "Mapping" And sh3.Name <> "TEST" And sh3.Name <> "Setting" And sh3.Name <> "(vide)" _
And sh3.Name <> "887" And sh3.Name <> "899" And sh3.Name <> "847" And sh3.Name <> "870" And sh3.Name <> "95F" And sh3.Name <> "95E" _
And sh3.Name <> "95C" And sh3.Name <> "DD" And sh3.Name <> "AD" And sh3.Name <> "CD" And sh3.Name <> "EL" And sh3.Name <> "FD" And sh3.Name <> "M2" Then
If Application.WorksheetFunction.VLookup(sh3.Range("J9").Value, ThisWorkbook.Sheets("Mapping").Range("A:K"), 10, False) Like "" Then
MsgBox sh3.Name & "CHECK" & " not egal to 0" & vbLf & vbLf & _
" Please correct and try again. ", vbOKOnly + vbExclamation
Exit Sub
End If
End If
Next sh3
If sh.Range("J9").Value <> "" Then
'Copie valeur et format de la feuille active dans un nouveau classeur
sh.PivotTables(1).TableRange1.Copy
Set Dest = Workbooks.Add(xlWBATWorksheet)
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Name = sh.Name
.Cells(1).Select
Application.CutCopyMode = False
End With
Set wb = ActiveWorkbook
'Nom du fichier envoyer
TempFileName = sh.Name & " Purge List " & ThisWorkbook.Sheets("Mapping").Range("A2")
Set OutMail = OutApp.CreateItem(0)
'insère la nouvelle feuille dans le mail
With wb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = ThisWorkbook.Sheets("Mapping").Range("L29").SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
With OutMail
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'destinataire = recherche v de la cellule J9 de chaque onglet dans mapping
.to = Application.WorksheetFunction.VLookup(sh.Range("J9").Value, ThisWorkbook.Sheets("Mapping").Range("A:K"), 6, False)
.CC = Application.WorksheetFunction.VLookup(sh.Range("J9").Value, ThisWorkbook.Sheets("Mapping").Range("A:K"), 7, False)
.BCC = ""
.Subject = "Purge List"
.HTMLBody = "Dear " & _
Application.WorksheetFunction.VLookup(sh.Range("J9").Value, ThisWorkbook.Sheets("Mapping").Range("A:K"), 4, False) & ",<br />" & _
RangetoHTML(rng)
.Attachments.Add wb.FullName
'Tu peux ajouter un autre fichier comme ci-dessous
'.Attachments.Add ("C:\test.txt")
.Send 'ou utilise .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
Set OutMail = Nothing
'Efface le fichier du disque dur que vous avez envoyé
Kill TempFilePath & TempFileName & FileExtStr
End If
End If
Next sh
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'Une boite de dialogue pour confirmer que l'email a bel et bien été envoyé
MsgBox Application.UserName & "," & vbCr & "These sheets were sent by email.", _
vbOKOnly + vbInformation, ActiveWorkbook.Name & " - Mailling "
Application.DisplayAlerts = True
End Sub
Bonjour,
Que vaut "RangetoHTML(rng)" ?
Cdlt
Bonjour, Bonjour Arturo,
RangetoHTML() n'est pas une fonction standard VBA. Une version est disponible (je pense dans le pack vba que tu peux trouver sur ce site) , tu peux aussi la copier à la suite de ton code, ou la créer toi-même.
tu reçois le message car vba ne trouve pas la fonction dans ton code.
Bonjour à tous,
La fonction, de Ron de Bruin (merci à lui), est disponible ici (et ailleurs) : https://www.rondebruin.nl/win/s1/outlook/bmail2.htm
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Cdlt,
Merci pour votre aide, mais désolé j'ai pas compris ce que je devais faire :(
Bonjour,
Votre code utilise la fonction RangeToHtml que vous n'avez pas définie. Je suis donc allé la rechercher pour que vous l'ajoutiez à votre projet (dans le module de la macro PURGELIST par exemple), afin de passer la compilation.
Cdlt,
Ah d'accord
Mais pour moi elle y est déjà dans la macro, car j'ai repris une macro que j'avais créé et qui fonctionne (je l'avais pris du même lien)
Si non, où dois je l'ajouter ?
Merci
Il faut l'ajouter dans le même module que PURGELIST.
il faut que je l'ajoute à quel niveau ?
Salut
Aprés cela
MsgBox Application.UserName & "," & vbCr & "These sheets were sent by email.", _
vbOKOnly + vbInformation, ActiveWorkbook.Name & " - Mailling "
Application.DisplayAlerts = True
End Sub
ce qui donne
'...
'...
MsgBox Application.UserName & "," & vbCr & "These sheets were sent by email.", _
vbOKOnly + vbInformation, ActiveWorkbook.Name & " - Mailling "
Application.DisplayAlerts = True
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
'...
'...
'...
Super ça fonctionne.
Il y avait un autre problème dans la macro que j'ai résolu.
Merci à vous !