XL 2019 importer le contenu d'une cellule sans ouvrir le fichier source VBA

P

PascalPax

XLDnaute Nouveau
bonjour a tous,
Je ne suis pas du tout expert en VBA, J'applique les codes utiles souvent récupérés et adaptés .
Aujourd'hui je butte sur la recup d'un contenu de cellule dans un classeur fermé en VBA (code joint).
Le code ne provoque pas d'erreur jusqu'à la msgbox.
Votre connaissance éclairera mon ignorance.
Merci
 

Pièces jointes

  • essai recup cellu.xlsm
    20.3 KB · Affichages: 8
  • test2.xlsm
    23.9 KB · Affichages: 11
Trier par date Trier par votes
Hasco

Hasco

XLDnaute Barbatruc
Repose en paix
Re,

Sinon, un lien vers votre cellule est suffisant ou alors votre macro modifiée:
Code: 
 Sub extractionValeurCelluleClasseurFerme()


    Dim Source As ADODB.Connection

    Dim ADOCommand As ADODB.Command
    Dim Rst As ADODB.Recordset
    Dim Fichier As String, Cellule As String, Feuille As String

    'Adresse de la cellule contenant la donnée à récupérer
    Cellule = "A3:A3"
    'Pour une plage de cellules, utilisez:
    'C'ellule = "A4:C10"

    NomFeuille = "essai$"    'n'oubliez pas d'ajouter $ au nom de la feuille.
    'Chemin complet du classeur fermé
    Fichier = ThisWorkbook.Path & "\test2.xlsm"

    Set Source = New ADODB.Connection
    Source.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                "Data Source=" & Fichier & ";Extended Properties=""Excel 12.0;HDR=NO;"";"
    Set Rst = Source.Execute("SELECT * FROM [" & NomFeuille & Cellule & "]""")

    MsgBox "Valeur de la cellule externe: " & Rst(0)

    Rst.Close
    Set Rst = Nothing
    Source.Close
    Set Source = Nothing


End Sub

bonne continuation
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
bonjour
un exemple avec mise en place des formules
VB: 
Option Explicit
'exemple formule de base
'"=IF('C:\Users\polux\DeskTop\Nouveau Dossier\[source.xlsm]Feuil1'!A1<>"""",'C:\Users\polux\DeskTop\Nouveau Dossier\[source.xlsm]Feuil1'!A1,"""")"
Sub test()
    Dim Cel As Range, formule$, chemin$, Pls As Range, feuille$, fichier$
  
  
    'la source
    Set Pls = Range("A1:D34") 'plage de la source a adapter
    feuille = "Feuil1" ' feuille de la source
    'fichier de la source par getopenfilename
    fichier = Application.GetOpenFilename(FileFilter:="Excel Files ( *.xlsx;*.xls;*.xlsm), ( *.xlsx;*.xls;*.xlsm), All Files, *.*", FilterIndex:=1)
  
    ' si on annule pas le dialog
    If fichier <> "" Then
        fichier = Mid(fichier, InStrRev(fichier, "\") + 1) 'nom cout du fichier source pour la formule

        'creation de la formule pour la premiere cellule
        formule = "'" & chemin & "[" & fichier & "]" & feuille & "'!" & Pls.Cells(1).Address(0, 0)
        formule = "=IF(" & formule & "<>""""," & formule & ","""")"

        Debug.Print formule ' pour verif

        'DESTINATION
        With Sheets(1).Range("A1") '1ere cellule de destination( c'est pas obligé que se soit la meme que la source )
          
            'inscription de la formule dans la 1 ere cellule
            .Formula = formule
          
            'on etend la formule vers le bas au meme nombre de ligne que la plage source
            .AutoFill Destination:=.Resize(Pls.Rows.Count, 1), Type:=xlFillDefault
          
            'on etend la formule vers la droite au meme nombre de colonnes que la plage source
            .Resize(Pls.Rows.Count, 1).AutoFill Destination:=.Resize(Pls.Rows.Count, Pls.Columns.Count), Type:=xlFillDefault
          
            'on remplace les formules par les valeurs
            .Resize(Pls.Rows.Count, Pls.Columns.Count).Value = .Resize(Pls.Rows.Count, Pls.Columns.Count).Value
        End With
    End If
End Sub

autre methode avec les macroxl4
ici une cellule ou une plage de cellule
Code: 
Sub récup_une_plage_de_cellules()
    Dim chemin$, fichier$, feuille$, cellule As Range, rang As Range
    chemin = "C:\Users\polux\Desktop"
    fichier = "nombre en lettre Monnaie Euro dollar v 2.0.xlsm"
    feuille = "Feuil1"
    Set rang = Range("A1:B10")
    tablo = (GetVal_on_closed_fich(chemin, fichier, feuille, rang))
    Cells(1, 1).Resize(UBound(tablo), UBound(tablo, 2)) = tablo
End Sub
Sub récup_une_seule_valeur()
    Dim chemin$, fichier$, feuille$, cellule As Range, rang As Range
    chemin = "C:\Users\polux\Desktop"
    fichier = "nombre en lettre Monnaie Euro dollar v 2.0.xlsm"
    feuille = "Feuil1"
    Set rang = Range("E3")
    MsgBox GetVal_on_closed_fich(chemin, fichier, feuille, rang)
  End Sub


'La fonction retourne un string ou tableau
'1 un string si l'argument "rang" est une seule celluleet donc sa valeur
'2 une variable tableau si rang est une plage de cellules  donc les !! valeurs dans une variable tableau

Function GetVal_on_closed_fich(ByVal chemin As String, ByVal fichier As String, ByVal feuille As String, rang As Range) As Variant
    Dim Rc$, tableau(), lig&, col&
    If rang.Cells.Count = 1 Then
        Rc = "R" & rang.Row & "C" & rang.Column
        GetVal_on_closed_fich = ExecuteExcel4Macro("'" & chemin & "\[" & fichier & "]" & feuille & "'!" & Rc)
    Else
        ReDim tableau(1 To rang.Rows.Count, 1 To rang.Columns.Count)
        For Each Cel In rang.Cells
            lig = Cel.Row: col = Cel.Column
            Rc = "R" & lig & "C" & col
            tableau(lig - rang.Row + 1, col - rang.Column + 1) = ExecuteExcel4Macro("'" & chemin & "\[" & fichier & "]" & feuille & "'!" & Rc)
        Next
        GetVal_on_closed_fich = tableau
    End If
End Function
dans la seconde tu peux intégrer 'getopenfilename pour avoir le dialog pour choisir ton fichier

sinon tu a adobconnection mais je vois que Roblochon m'a devancé ;) mais pour une seule cellule ça fait un peu lourd
 
Dernière édition:
Vote positif 0 Vote négatif
P

PascalPax

XLDnaute Nouveau
Roblochon à dit:
Re,

Sinon, un lien vers votre cellule est suffisant ou alors votre macro modifiée:
Code: 
Sub extractionValeurCelluleClasseurFerme()


    Dim Source As ADODB.Connection

    Dim ADOCommand As ADODB.Command
    Dim Rst As ADODB.Recordset
    Dim Fichier As String, Cellule As String, Feuille As String

    'Adresse de la cellule contenant la donnée à récupérer
    Cellule = "A3:A3"
    'Pour une plage de cellules, utilisez:
    'C'ellule = "A4:C10"

    NomFeuille = "essai$"    'n'oubliez pas d'ajouter $ au nom de la feuille.
    'Chemin complet du classeur fermé
    Fichier = ThisWorkbook.Path & "\test2.xlsm"

    Set Source = New ADODB.Connection
    Source.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                "Data Source=" & Fichier & ";Extended Properties=""Excel 12.0;HDR=NO;"";"
    Set Rst = Source.Execute("SELECT * FROM [" & NomFeuille & Cellule & "]""")

    MsgBox "Valeur de la cellule externe: " & Rst(0)

    Rst.Close
    Set Rst = Nothing
    Source.Close
    Set Source = Nothing


End Sub

bonne continuation
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
Hasco

Hasco

XLDnaute Barbatruc
Repose en paix
Re,

Dans le fichier joint,

Un test de solution par PowerQuery (pour exemple) et la macro modifiée pour qu'elle ne ramène que le dernier n° non null de la plage A1:A10000 de la feuille essai du classeur source.
Re changer le chemin vers le répertoire.
VB: 
 Sub extractionValeurCelluleClasseurFerme()


    Dim Source As ADODB.Connection

    Dim ADOCommand As ADODB.Command
    Dim Rst As ADODB.Recordset
    Dim Fichier As String, Cellule As String, Feuille As String

    'Adresse de la cellule contenant la donnée à récupérer
    Cellule = "A3:A3"
    'Pour une plage de cellules, utilisez:
    'C'ellule = "A4:C10"

    nomfeuille = "essai$"    'n'oubliez pas d'ajouter $ au nom de la feuille.
    'Chemin complet du classeur fermé
    Fichier = ThisWorkbook.Path & "\test2.xlsm"

    Set Source = New ADODB.Connection
    Source.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                "Data Source=" & Fichier & ";Extended Properties=""Excel 12.0;HDR=NO;"";"
    Source.CursorLocation = adUseClient
    
    Set Rst = New ADODB.Recordset
    Rst.Open "SELECT * FROM [" & nomfeuille & "A1:A10000] WHERE NOT ISNULL(F1);", Source, adOpenStatic, adLockReadOnly
    If Rst.RecordCount > 0 Then Rst.MoveLast
    'Set Rst = Source.Execute("SELECT * FROM [" & NomFeuille & Cellule & "]""")

    Sheets("Feuil1").Range("B5") = Rst("F1")

    Rst.Close
    Source.Close
    Set Source = Nothing
    Set Rst = Nothing
    Set ADOCommand = Nothing
End Sub

Cordialement
 

Pièces jointes

  • essai recup cellu.xlsm
    29.5 KB · Affichages: 18
Vote positif 0 Vote négatif
P

PascalPax

XLDnaute Nouveau
Roblochon à dit:
Re,

Dans le fichier joint,

Un test de solution par PowerQuery (pour exemple) et la macro modifiée pour qu'elle ne ramène que le dernier n° non null de la plage A1:A10000 de la feuille essai du classeur source.
Re changer le chemin vers le répertoire.
VB: 
Sub extractionValeurCelluleClasseurFerme()


    Dim Source As ADODB.Connection

    Dim ADOCommand As ADODB.Command
    Dim Rst As ADODB.Recordset
    Dim Fichier As String, Cellule As String, Feuille As String

    'Adresse de la cellule contenant la donnée à récupérer
    Cellule = "A3:A3"
    'Pour une plage de cellules, utilisez:
    'C'ellule = "A4:C10"

    nomfeuille = "essai$"    'n'oubliez pas d'ajouter $ au nom de la feuille.
    'Chemin complet du classeur fermé
    Fichier = ThisWorkbook.Path & "\test2.xlsm"

    Set Source = New ADODB.Connection
    Source.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                "Data Source=" & Fichier & ";Extended Properties=""Excel 12.0;HDR=NO;"";"
    Source.CursorLocation = adUseClient
   
    Set Rst = New ADODB.Recordset
    Rst.Open "SELECT * FROM [" & nomfeuille & "A1:A10000] WHERE NOT ISNULL(F1);", Source, adOpenStatic, adLockReadOnly
    If Rst.RecordCount > 0 Then Rst.MoveLast
    'Set Rst = Source.Execute("SELECT * FROM [" & NomFeuille & Cellule & "]""")

    Sheets("Feuil1").Range("B5") = Rst("F1")

    Rst.Close
    Source.Close
    Set Source = Nothing
    Set Rst = Nothing
    Set ADOCommand = Nothing
End Sub

Cordialement
Cliquez pour agrandir...
Roblochon à dit:
Re,

Dans le fichier joint,

Un test de solution par PowerQuery (pour exemple) et la macro modifiée pour qu'elle ne ramène que le dernier n° non null de la plage A1:A10000 de la feuille essai du classeur source.
Re changer le chemin vers le répertoire.
VB: 
Sub extractionValeurCelluleClasseurFerme()


    Dim Source As ADODB.Connection

    Dim ADOCommand As ADODB.Command
    Dim Rst As ADODB.Recordset
    Dim Fichier As String, Cellule As String, Feuille As String

    'Adresse de la cellule contenant la donnée à récupérer
    Cellule = "A3:A3"
    'Pour une plage de cellules, utilisez:
    'C'ellule = "A4:C10"

    nomfeuille = "essai$"    'n'oubliez pas d'ajouter $ au nom de la feuille.
    'Chemin complet du classeur fermé
    Fichier = ThisWorkbook.Path & "\test2.xlsm"

    Set Source = New ADODB.Connection
    Source.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                "Data Source=" & Fichier & ";Extended Properties=""Excel 12.0;HDR=NO;"";"
    Source.CursorLocation = adUseClient
   
    Set Rst = New ADODB.Recordset
    Rst.Open "SELECT * FROM [" & nomfeuille & "A1:A10000] WHERE NOT ISNULL(F1);", Source, adOpenStatic, adLockReadOnly
    If Rst.RecordCount > 0 Then Rst.MoveLast
    'Set Rst = Source.Execute("SELECT * FROM [" & NomFeuille & Cellule & "]""")

    Sheets("Feuil1").Range("B5") = Rst("F1")

    Rst.Close
    Source.Close
    Set Source = Nothing
    Set Rst = Nothing
    Set ADOCommand = Nothing
End Sub

Cordialement
Cliquez pour agrandir...

bonjour,
Je relance ce post, car je dois réussir a augmenter la valeur récupérée de "1" à chaque exécution.
Comment valider "RST("F1").value+1"
j'ai une erreur a chaque fois.
Merci d'avance de vos lumières
 
Vote positif 0 Vote négatif

Discussions similaires

K
  • Question
Microsoft 365 Récupérer le contenu en texte d'une cellule ayant un format personnalisé (sans VBA)
Réponses
9
Affichages
872
Efgé
Efgé
F
  • Question
Microsoft 365 Sans VBA - Titre d'un graphique en lien avec le contenu de certaines cellule
Réponses
6
Affichages
504
Deadpool_CC
Deadpool_CC
P
  • Question
Microsoft 365 VBA, source d'une référence
Réponses
2
Affichages
1 K
Daniel Bretelles
Daniel Bretelles
J
  • Question
XL 2019 importer le contenu de plusieurs xlsx dans une même sheet d'un nouveau fichier excel
2 3
Réponses
34
Affichages
3 K
Hasco
Hasco
Gaalhad33
  • Résolu(e)
XL 2013 VBA - macro pour ouvrir un fichier en fonction de la valeur d'une cellule
Réponses
4
Affichages
681
Gaalhad33
Gaalhad33
J
  • Question
XL 2013 VBA - ADO - requête fait ouvrir le fichier source 2
Réponses
14
Affichages
982
JLE
J
E
  • Résolu(e)
XL 2013 [VBA] Check contenu d'une cellule dans une autre feuille avec un retour via MsgBox
Réponses
10
Affichages
1 K
Eawyne
E
J
  • Question
XL 2016 Importer données depuis fichier source - VBA
Réponses
0
Affichages
2 K
james7734
J
F
  • Question
XL pour MAC MACRO POUR AFFICHER LE DETAIL D'UN TCD à PARTIR D'UNE CELLULE
Réponses
4
Affichages
1 K
florestan75
F
E
  • Résolu(e)
XL 2016 [VBA] Afficher le contenu d'une Textbox (userform) et d'une Listbox (userform) dans une seule et même cellule d'un tableau
Réponses
2
Affichages
3 K
elx
E

Membres actuellement en ligne

5 membres et 56 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 206
Messages
2 086 203
Membres
103 157
dernier inscrit
youma