Conseil VBA

Salut tout le monde,

J'ai adapté un code VBA pour pouvoir copier des données d'un classeur fermé dans le classeur où se trouve cette macro et dès son ouverture (il fonctionne très bien).

Je voulais savoir si le code n'avait pas d'infos inutiles ? ou s'il pouvait être amélioré niveau syntaxe ?

Private Sub Workbook_Open()

' --------------------------------------------------------
' Récupérer le contenu de classeurs fermés sans les ouvrir
' --------------------------------------------------------
' La récupération suppose la présence de noms de champs (des mots)
' Procédure testée sous Excel 2003 et 2010

Dim Cn As ADODB.Connection ' Définir une variable ADODB Connection
Dim Rst As ADODB.Recordset ' Pour accueillir un RecordSet
Dim req_SQL As String ' Contiendra la Requête SQL

Dim Fichier As String ' Nom du fichier (classeur)
Dim chem_fichier As String ' Chemin + nom du fichier
Dim NomFeuille As String ' Nom de la feuille à traiter
Dim chemin As String ' Chemin d'accès aux fichiers à traiter

chemin = "M:\04 - INDUSTRIE\4- PRODUCTION\RB\2-DOCUMENTS USINE\"

' Définir le premier classeur à traiter
Fichier = Dir(chemin & "Base Mère.xlsm") ' Pointer les fichiers f*.xls et f*.xlsx
chem_fichier = chemin & Fichier

' Nom de la feuille à traiter dans le classeur fermé
NomFeuille = "Base Qualité"

   Set Cn = New ADODB.Connection ' Créer une nouvelle instance

   ' --- Connexion à la source (pour nous, un classeur)
   With Cn
   .Provider = "Microsoft.Jet.OLEDB.4.0"
   .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
   & chem_fichier & ";Extended Properties=""Excel 12.0;HDR=YES;"""
   .Open
   End With
   ' --- Fin Connexion

   req_SQL = "SELECT * FROM [" & NomFeuille & "$]"

   Set Rst = New ADODB.Recordset ' Récupérer un ensemble d'enreg.
   Set Rst = Cn.Execute(req_SQL) ' Exécuter la requête SQL

   ' Copier les données à partir dans la Feuil1 à partir de la cellule A1
   Feuil1.Range("A1").CopyFromRecordset Rst

   '--- Fermeture de la connexion ---
   Cn.Close
   Set Cn = Nothing ' Libérer la ressource

End Sub

Merci

Clem

Bonjour Clem,

A part tous les commentaires, il n'y a pas de ménage spécifique à faire et le code optimisé

Après on peut faire toujours plus court, mais moins compréhensible à la lecture

Bonjour à tous,

2 remarques :

* Personnellement je n'utilise plus Jet (provider un peu ancien), et dans le code c'est inutile d'utiliser 2 providers différents Jet et ACE à la file! Pour des fichiers Excel autant utiliser MsdaSql

* Le Execute est correct pour des Update et Insert, pour des Select il vaux mieux un Open.

Voici une proposition :

Dim Cnx As Object, Rst As Object
DIm T as variant

    '...

    Set Cnx = CreateObject("ADODB.Connection")
    Set Rst = CreateObject("ADODB.Recordset")

    Cnx.Provider = "MSDASQL"
    Cnx.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & _
             "DBQ=" & chem_fichier & "; ReadOnly=False;"

    req_SQL = "SELECT * FROM [" & NomFeuille & "$]"

    Rst.Open req_SQL, Cnx, 3
    Rst.MoveFirst
    T = Rst.GetRows
    Feuil1.Range("A1").Resize(UBound(T, 1), UBound(T, 2)) = T

    Cnx.Close
    Set Cn = Nothing
    Set Rst = Nothing

nb : ainsi le Rst peux aussi récupérer les entêtes si besoin (Rst.Fields(x).name)

Pierre

Merci pour vos réponses !

pierrep56, j'ai testé ton code mais j'obtiens ce message d'erreur :

D'après le pas à pas, le bug arrive entre ces deux lignes de code :

 T = Rst.GetRows
    Feuil1.Range("A1").Resize(UBound(T, 1), UBound(T, 2)) = T

Mais je ne vois pas du tout pourquoi ?

Clem

Tu as probablement les valeurs "NULL" dans les données. Pour contourner :

Dim T As Variant, Rcd As Variant
Dim lig As Long, col As Long, i As Long, j As Long

    '...
    ReDim Rcd(1 To 1, 1 To 1)
    Rst.Open req, Cnx, 3
    lig = Rst.RecordCount
    If lig > 0 Then
        Rst.MoveFirst
        T = Rst.GetRows
        col = Rst.Fields.Count
        ReDim Rcd(1 To lig + 1, 1 To col)
        For j = 0 To col - 1
            Rcd(1, j + 1) = Rst.Fields(j).Name
            For i = 0 To lig - 1
                Rcd(i + 2, j + 1) = IIf(IsNull(T(j, i)), 0, T(j, i))
            Next i
        Next j
    End If

    Feuil1.Range("A1").Resize(UBound(Rcd, 1), UBound(Rcd, 2)) = Rcd

    Cnx.Close
    Set Cnx = Nothing
    Set Rst = Nothing

Pierre

Oui effectivement j'ai pas mal de valeurs nulles

J'ai testé ton nouveau code (il faudra que je me pose pour bien le comprendre je crois)

Mais maintenant j'ai cette nouvelle erreur :

"erreur d'exécution 3001 : erreur définie par l'application ou par l'objet"

J'ai fait une boulette dans mon code ?

Private Sub Workbook_Open()

Dim T As Variant, Rcd As Variant
Dim lig As Long, col As Long, i As Long, j As Long
Dim Cnx As Object, Rst As Object

Dim Fichier As String ' Nom du fichier (classeur)
Dim chem_fichier As String ' Chemin + nom du fichier
Dim NomFeuille As String ' Nom de la feuille à traiter
Dim chemin As String ' Chemin d'accès aux fichiers à traiter

chemin = "M:\04 - INDUSTRIE\4- PRODUCTION\RB\2-DOCUMENTS USINE\"

' Définir le premier classeur à traiter
Fichier = Dir(chemin & "Base Mère.xlsm") ' Pointer les fichiers f*.xls et f*.xlsx
chem_fichier = chemin & Fichier

' Nom de la feuille à traiter dans le classeur fermé
NomFeuille = "Base Qualité"

Set Cnx = CreateObject("ADODB.Connection")
    Set Rst = CreateObject("ADODB.Recordset")

    Cnx.Provider = "MSDASQL"
    Cnx.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & _
             "DBQ=" & chem_fichier & "; ReadOnly=False;"

    req_SQL = "SELECT * FROM [" & NomFeuille & "$]"

    ReDim Rcd(1 To 1, 1 To 1)
    Rst.Open req, Cnx, 3
    lig = Rst.RecordCount
    If lig > 0 Then
        Rst.MoveFirst
        T = Rst.GetRows
        col = Rst.Fields.Count
        ReDim Rcd(1 To lig + 1, 1 To col)
        For j = 0 To col - 1
            Rcd(1, j + 1) = Rst.Fields(j).Name
            For i = 0 To lig - 1
                Rcd(i + 2, j + 1) = IIf(IsNull(T(j, i)), 0, T(j, i))
            Next i
        Next j
    End If

    Feuil1.Range("A1").Resize(UBound(Rcd, 1), UBound(Rcd, 2)) = Rcd

    Cnx.Close
    Set Cnx = Nothing
    Set Rst = Nothing

End Sub

Clem

Et je viens de remarquer qu'en fait il m'ouvrait mon autre classeur (Base qualité)

Mais moi je ne veux pas qu'il m'ouvre mon autre classeur mais juste qu'il me copie un onglet de ce classeur dans mon classeur actif

Clem

Re,

Comme quoi le vieil adage est toujours de rigueur : "Le mieux est l'ennemi du bien" à méditer

Par contre avec mon tout premier code certaines données ne se copient pas

Et je ne sais pas du tout pourquoi...

Les cellules contiennent du texte ou des chiffres comme les autres cellules qui elles se copient par contre ...

Quelqu’un a une idée ?

Clem

Re,

Bon j'ai fini par trouver un autre code qui fonctionne encore mieux (là toutes mes données son bien copiées)

Sub ImporterDonneesSansOuvrir()

Dim Cheminsource As String, Fichiersource As String

Cheminsource = "M:\04 - INDUSTRIE\4- PRODUCTION\RB\2-DOCUMENTS USINE\"
Fichiersource = "Base Mère.xlsm"

ThisWorkbook.Names.Add "plage", _
            RefersTo:="='" & Cheminsource & "[" & Fichiersource & "]Base Qualité'!$A$1:JOF$1000"

        Worksheets("Feuil2").Range("A1:JO1000").Value = "=plage"

End Sub

A la base, il y avait with Feuil1 en plus mais je ne vois pas à quoi il sert ?? je l'ai retiré et ça fonctionne aussi

Sub ImporterDonneesSansOuvrir()

Dim Cheminsource As String, Fichiersource As String

Cheminsource = "M:\04 - INDUSTRIE\4- PRODUCTION\RB\2-DOCUMENTS USINE\"
Fichiersource = "Base Mère.xlsm"

ThisWorkbook.Names.Add "plage", _
            RefersTo:="='" & Cheminsource & "[" & Fichiersource & "]Base Qualité'!$A$1:JOF$1000"

    With Worksheets("Feuil1")

        Worksheets("Feuil2").Range("A1:JO1000").Value = "=plage"
      End With

End Sub