Function GetValueWithADO(Classeur As String, _
Feuille As String, CellAdresse As String, Critère As String)
'Microsoft ActiveX Data Objects 2.8 Library
Dim Rst As New ADODB.Recordset
Dim Conn As New Connection
Dim Requete As String
Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & Classeur & ";" & _
"Extended Properties=""Excel 12.0;HDR=NO;"""
Requete = "SELECT F2 FROM [" & Feuille & "$" & CellAdresse & "]" & _
"Where F1 like '" & Critère & "'"
Rst.Open Requete, Conn, adOpenStatic, adLockReadOnly, adCmdText
If Rst.RecordCount > 0 Then
GetValueWithADO = Application.Clean(Rst.GetString(NumRows:=1))
Else
GetValueWithADO = ""
End If
Rst.Close: Conn.Close
Set Rst = Nothing: Set Conn = Nothing
End Function
=============================
Sub mail()
Dim OutApp As Object, OutMail As Object
Dim Destinataire As String
Dim Fichier As String, Feuille As String
Dim CellAdr As String, Critère As String
'-------Variables à renseigner---------
Fichier = ThisWorkbook.Path & "\fichier fermé.xlsx"
Feuille = "Sheet1"
CellAdr = Range("A:B").Address(0, 0)
Critère = Worksheets("Sheet1").Range("A4")
'---------------------------------------
Destinataire = GetValueWithADO(Fichier, _
Feuille, CellAdr, Critère)
If Destinataire = "" Then
MsgBox "L'usager """ & Critère & """ " & _
"n 'existe pas dans la table.", _
vbCritical + vbOKOnly, "Attention"
Exit Sub
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Destinataire
.CC = ""
.BCC = ""
.Subject = "bla bla bla"
.Body = "bla bla bla"
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub