Copier dans un classeur ouvert le contenu d'une cellule d'un classeur fermé

Bonjour,

A ) Dans la fenêtre de l'éditeur de code (VBA), barre des menus / outils / références
et tu coches la référence suivante : "Microsoft ActiveX Data Objects 2.8 Library"

B ) Dans un module STANDARD, tu copies cette fonction personnalisée
'-----------------------------------------------------
Function ValCell(ByVal File As String, _
ByVal Feuille As String, ByVal Rg As String)
'ajouter une référence
'Microsoft ActiveX Data Objects 2.8 Library
Dim Rst As New ADODB.Recordset
Dim Conn As ADODB.Connection
Dim Requete As String

On Error Resume Next
Rg = Rg & ":" & Rg
Requete = "SELECT * FROM [" & Feuille & "$" & Rg & "]"
Set Conn = New ADODB.Connection
If Val(Application.Version) > 11 Then
Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & File & ";" & _
"Extended Properties=""Excel 12.0;HDR=NO;IMEX=1;"";"
Else
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & File & ";" & _
"Extended Properties=""Excel 8.0;HDR=NO;IMEX=1;"";"
End If
Rst.Open Requete, Conn, adOpenStatic, adLockOptimistic
If Rst.RecordCount > 0 Then
ValCell = Rst(0).Value
Else
ValCell = "Pas trouvé"
End If
End Function
'-----------------------------------------------------

C ) Dans la cellule de ton application où doit s'inscrire la valeur recherchée dans un
classeur fermé, d'une feuille particulière et d'une adresse précise, tu inscris cette formule :
(Ce n'est qu'un exemple, tu dois adapter avec l'adresse complète de la location du fichier,
le nom de la feuille où se retrouve la valeur recherchée, et l'adresse de ladite cellule :

=ValCell("C:UsersTon ProfilDocumentsADO_liste_deroule.xlsm";"Feuil2";"A25")


MichD
--------------------------------------------------------------

Juste un détail, si tu veux que les cellules contenant cette fonction se mettent à jour,
il y a 2 façons de procéder :

A ) En tout début de la fonction, tu ajoutes la ligne de code suivante :
Application.Volatile
Cette approche demande beaucoup de ressources puisque la fonction est
réévaluée à chaque fois qu'il y a "calcul" dans la feuille.

B ) Dans le ThisWorkbook du classeur, tu demandes expressément la mise à jour
selon la disposition des cellules concernées :

'----------------------------------------------
Private Sub Workbook_Open()
'pour seulement quelques cellules :
With ThisWorkbook
.Worksheets("Feuil1").Range("G25").Calculate
.Worksheets("Feuil5").Range("H62").Calculate
'.../...
End With

'Si toutes les cellules se retrouvent sur la même feuille
'Mise à jour de toutes les cellules de la Feuil3
ThisWorkbook.Worksheets("Feuil3").Calculate

'Si tu as plusieurs feuilles, tu peux demander la
'mise à jour du classeur au complet
Application.Calculate
End Sub
'----------------------------------------------


MichD
--------------------------------------------------------------

Dernier détail :

Ajoute ces 2 lignes de code à la fonction personnalisée, la ligne juste avant "End Function"
afin de s'assurer de libérer les objets et l'espace mémoire qu'ils occupent.

Rst.Close: Cnn.Quit
Set Rst = Nothing: Set Cnn = Nothing

La fonction devient :
'-----------------------------------------------------
Function ValCell(ByVal File As String, _
ByVal Feuille As String, ByVal Rg As String)
'ajouter une référence
'Microsoft ActiveX Data Objects 2.8 Library
Dim Rst As New ADODB.Recordset
Dim Conn As ADODB.Connection
Dim Requete As String

On Error Resume Next
Rg = Rg & ":" & Rg
Requete = "SELECT * FROM [" & Feuille & "$" & Rg & "]"
Set Conn = New ADODB.Connection
If Val(Application.Version) > 11 Then
Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & File & ";" & _
"Extended Properties=""Excel 12.0;HDR=NO;IMEX=1;"";"
Else
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & File & ";" & _
"Extended Properties=""Excel 8.0;HDR=NO;IMEX=1;"";"
End If
Rst.Open Requete, Conn, adOpenStatic, adLockOptimistic
If Rst.RecordCount > 0 Then
ValCell = Rst(0).Value
Else
ValCell = "Pas trouvé"
End If
Rst.Close: Cnn.Quit
Set Rst = Nothing: Set Cnn = Nothing
End Function
'-----------------------------------------------------

MichD
--------------------------------------------------------------

Ok ! Merci beaucoup pour cette réponse très complète et très préc ise !!!! Je teste !