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

Le
Josephine
Bonjour, j'utilise excel 2010 et je souhaite dans mon classeur ouvert
recuperer dans une cellule le contenu d'une cellule d'un autre
classeur qui est fermé (et que je ne souhaite pas ouvrir), ceci en
vba. Existe t il une méthode simple ? Car il va falloir que je
récupère le contenu de plusieurs cellules qui sont toutes dans
différents classeurs fermés (9 au total et dans chacun 4 cellules à
récupérer). Merci.
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
MichD
Le #24754622
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
--------------------------------------------------------------
MichD
Le #24754722
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
--------------------------------------------------------------
MichD
Le #24754712
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
--------------------------------------------------------------
Josephine
Le #24756252
Ok ! Merci beaucoup pour cette réponse très complète et très préc ise !!!! Je teste !
Publicité
Poster une réponse
Anonyme