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 !

Rechercher des sujets similaires à "erreur compilation sub fonction definie"