XL 2019 Macro recuperation de données

[Mikod38]

Bonjour,
Je suis nouveau ici, je ne connais pas grand chose en VBA et j'aurais besoin de votre aide.
j'arrive à lire le code mais je ne sais le construire ...
Donc je cherche une macro afin de recuperer des données d'un fichier que j'extrais (qui change de nom à chaque extraction), son nom pour l'exemple sera "extraction".
Celui-ci ne sera que ouvert, le transfert se fera par une combinaison CTRL+T (si possible) puis se refermera.
De celui-ci, je voudrais les colonnes où les chiffres sont en jaune afin de remplir l'autre classeur "Pacte" sans effacer les données récupérées la semaine precedente.
Pouvez vous m'aider ?
Je vous remercie d'avance

 

[patricktoulon]

bonjour
un petit essai avec ADO sans ouvrir le fichier extraction
je fait en 2 fois car je ne sais pas faire en une fois avec des colonnes non contiguës
je sais meme pas si c'est possible avec ADO le non contiguës

bref pour ce fichier ca sera ceci
ADAPTE LE CHEMIN DU FICHIER CHEZ TOI
au pire on pourrais intégrer un dialog pour sélectionner le fichier
il faudra aussi peut être une autre requête pour déterminer le nom de la feuille ci celui ci change selon les fichiers
tout ça tu ne la pas déterminé dans ton enoncé 🙄 😉
allez allons y pour celui là

ps; activer a minima la reference: Micosoft ActivX Data Object 2.0 library
il peut y en avoir plusieurs mais c'est la 2.0 qui est compatible avec tout le monde

Sub testAdO()
    Dim fichier As String, nomfeuille As String, DispoCel As Range

    fichier = "C:\Users\polux\DeskTop\extraction.xlsx"
    nomfeuille = "ISPA_Donnees_brutes_A73625_02_1"

    Set DispoCel = Feuil1.Cells(Rows.Count, "A").End(xlUp).Offset(1)


    resADO [B5:B65000], fichier, nomfeuille, DispoCel
    resADO [H5:Ai65000], fichier, nomfeuille, DispoCel.Offset(, 1)

End Sub
Function resADO(plage, fichier, nomfeuille, destination)

    Dim Cn As ADODB.Connection, texte_SQL$, Rst As ADODB.Recordset

    Set Cn = New ADODB.Connection

    '--- Connection ---
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=" & fichier & ";Extended Properties=""Excel 12.0;HDR=NO;"";"
    '-----------------

    'la requête.
    ' Attention!!!!!!! à ne pas oublier le symbole "$" après le nom de la feuille.
    texte_SQL = "SELECT * FROM [" & nomfeuille & "$" & plage.Address(0, 0) & "]"


    Set Rst = New ADODB.Recordset
    Set Rst = Cn.Execute(texte_SQL)

    destination.CopyFromRecordset Rst
    '--- Fermeture connexion ---
    Cn.Close
    Set Cn = Nothing

End Function

 

[Mikod38]

merci bcp,
mais je ne veux pas enregistrer le fichier "extraction", je veux juste l'ouvrir suite à une extraction depuis un logiciel interne. c'est là ma plus grande difficulté !!!

 

[Mikod38]

de plus le nom de la feuille evolue aussi en fonction de l'extration

 

[patricktoulon]

re
woawh!!!
ça démarre mal
qui te parle de l'ouvrir ???
met ce code dans un module standard du fichier pactexlsx sauve le en xlsm
modifie le chemin du fichier
et lance la sub
et puis c'est tout 😉
démonstration

 

[Mikod38]

c'est ce que je fait mais je tombe sur un message d'erreur ...

 

[patricktoulon]

re
oui et est ce que ce qui est écrit en rouge et bleu dans ma réponse est suffisamment visible pour toi ? 😉

 

[fanch55]

Salut,
Pour Excel 2016 et surement 2019 : ( la 2.0 génère des erreurs )

 

[patricktoulon]

bonjour fanch55
tu dois avoir certainement la 2.0 as dispo
je met celle ci parce que tout le monde est sensé l'avoir 😉

 

[Mikod38]

merci, je ne trouver pas l'acces au reference car j'etais dans le debogeur ...
MErci bcp bcp
a bientot

 

[fanch55]

bonjour fanch55
tu dois avoir certainement la 2.0 as dispo
je met celle ci parce que tout le monde est sensé l'avoir 😉

Salut Patrick, la 2.0 fonctionne correctement avec ton code . 😉

 

[patricktoulon]

oui ca fonctionne nickel
et pour ne plus etre ennuyé avec ca on passe en déclaration tardive (late binding) donc pas de ref a activer

Function resADO(plage, fichier, nomfeuille, destination)

'Dim Cn As ADODB.Connection, texte_SQL$, Rst As ADODB.Recordset
    Dim Cn As Object, texte_SQL$, Rst As Object


    'Set Cn = New ADODB.Connection
    Set Cn = CreateObject("ADODB.Connection")

    '--- Connection ---
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=" & fichier & ";Extended Properties=""Excel 12.0;HDR=NO;"";"
    '-----------------

    'la requête.
    ' Attention!!!!!!! à ne pas oublier le symbole "$" après le nom de la feuille.
    texte_SQL = "SELECT * FROM [" & nomfeuille & "$" & plage.Address(0, 0) & "]"


    'Set Rst = New ADODB.Recordset
    Set Rst = CreateObject("ADODB.RecordSet")
    Set Rst = Cn.Execute(texte_SQL)

    destination.CopyFromRecordset Rst
    '--- Fermeture connexion ---
    Cn.Close
    Set Cn = Nothing

End Function

 

[fanch55]

Je rajouterai peut-être

    Feuil1.Columns("A").NumberFormat = "dd/mm/yyyy"
    Feuil1.Columns("A:Ac").AutoFit

en fin de la sub TestAdo 🙂

 

[patricktoulon]

re
si tu veux ça mange pas de pain 😉

 

[patricktoulon]

tiens kado
@Mikod38 @fanch55
on ne connais que l'index du sheets on va chercher son nom

Option Explicit

Sub testAdO()
    Dim fichier As String, nomfeuille As String, DispoCel As Range

    fichier = "C:\Users\polux\DeskTop\extraction.xlsx"

    'nomfeuille = "ISPA_Donnees_brutes_A73625_02_1"
    nomfeuille = GetNameSheetsWithIndex("C:\Users\polux\DeskTop\extraction.xlsx", 1)    'on connais pas le nom de la feuille(1) on va le chercher

    Set DispoCel = Feuil1.Cells(Rows.Count, "A").End(xlUp).Offset(1)

    resADO [B5:B65000], fichier, nomfeuille, DispoCel
    resADO [H5:Ai65000], fichier, nomfeuille, DispoCel.Offset(, 1)

    Feuil1.Columns("A").NumberFormat = "dd/mm/yyyy"
    Feuil1.Columns("A:AI").AutoFit
End Sub
Function resADO(plage, fichier, nomfeuille, destination)
    Dim Cn As Object, texte_SQL$, rst As Object
    Set Cn = CreateObject("ADODB.Connection")

    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=" & fichier & ";Extended Properties=""Excel 12.0;HDR=NO;"";"
    ' la requête.Attention!!!!!!! à ne pas oublier le symbole "$" après le nom de la feuille.
    texte_SQL = "SELECT * FROM [" & nomfeuille & "$" & plage.Address(0, 0) & "]"

    Set rst = CreateObject("ADODB.RecordSet")
    Set rst = Cn.Execute(texte_SQL)

    destination.CopyFromRecordset rst
    '--- Fermeture connexion ---
    Cn.Close
    Set Cn = Nothing: Set rst = Nothing

End Function

Function GetNameSheetsWithIndex(fichier$, Optional index As Long = 0)
    Dim cnx As Object, rst As Object, res() As String, nm As String, i As Integer
    Const adSchemaTables As Integer = 20
    On Error GoTo FIN
    '
    Set cnx = CreateObject("ADODB.Connection")    ' création des object Adodb
    cnx.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & fichier & ";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    cnx.Open
    '
    Set rst = cnx.OpenSchema(adSchemaTables)    '20
    Do Until rst.EOF = True    ' interrogation du catalogue
        nm = rst.Fields!Table_Name.Value
        If Right(nm, 1) = "$" Then
            i = i + 1
            ReDim Preserve res(1 To i)
            res(i) = Left(nm, Len(nm) - 1)
        End If
        rst.MoveNext
    Loop
    rst.Close: cnx.Close    ' Fermeture des objets recordset et connexion
FIN:

    Set rst = Nothing: Set cnx = Nothing    ' Nettoyage des objets et gestion des erreurs

    If Err.Number <> 0 Then
        MsgBox "Opération interrompue en raison de l'erreur suivante :" & vbCrLf & vbCrLf & Err.Description, vbExclamation, "Lister feuilles classeur fermé"
        ReDim res(1 To 1): res(1) = "nofound!!"
    End If
    On Error GoTo 0
    If index = 0 Then GetNameSheetsWithIndex = res Else GetNameSheetsWithIndex = res(index)
End Function

'exemple d'utilisation de la fonction
'la fonction peut retourner un string ou un array
Sub test()
' en string
    nomfeuille = GetNameSheetsWithIndex("C:\Users\polux\DeskTop\extraction.xlsx", 1)
    MsgBox nomfeuille
    'en array
    listefeuille = GetNameSheetsWithIndex("C:\Users\polux\DeskTop\extraction.xlsx")
    MsgBox listefeuille(1)
End Sub