XL 2019 Macro recuperation de données

Mikod38

XLDnaute Nouveau
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
 

Pièces jointes

  • extraction.xlsx
    30.1 KB · Affichages: 17
  • pacte.xlsx
    15.4 KB · Affichages: 6
Solution
tiens kado
@Mikod38 @fanch55
on ne connais que l'index du sheets on va chercher son nom
VB:
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...

patricktoulon

XLDnaute Barbatruc
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é :rolleyes: ;)
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


VB:
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
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
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
demo6.gif
 

patricktoulon

XLDnaute Barbatruc
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
VB:
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
 

patricktoulon

XLDnaute Barbatruc
tiens kado
@Mikod38 @fanch55
on ne connais que l'index du sheets on va chercher son nom
VB:
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
 

Discussions similaires

Réponses
65
Affichages
3 K