Macro pour aller chercher des données d'un autre excel vers le fichier de la macro.

[Keiko]

Bonour à tous,

Voici mon idée de macro afin d'aller chercher des données d'un fichier externe vers le mien.

Fichier source : C:\PPV\United Focus\PPV - Documents\prix
Fichier ou est la macro et ou les données doivent arriver = C:\Users\Dethier Jonathan\Desktop\United 16-9-22\

Pensez-vous que cela soit possible?

Bien à vous,

Public chemin(1 To 10) As String
Public fichier(1 To 10) As String
Public feuille(1 To 10) As String
Public cellules(1 To 10) As String

Sub Rectangle2_Cliquer()
'chemin à modifier si le classeur source n'est pas _
dans le même dossier par "C:\Users\lea\Documents\"
chemin(1) = ThisWorkbook.Path
fichier(1) = "C:\PPV\United Focus\PPV - Documents\prix.xls"
'A modifier si la feuille n'est pas la même _
ou si elle a un nom différent
feuille(1) = "PV"
'Là aussi, si plage plus grande.
cellules(1) = "a1:e52"
GetData chemin(1) & fichier(1), feuille(1), cellules(1), _
ActiveSheet.Range("a1"), True, True

chemin(2) = "C:\Users\Dethier Jonathan\Desktop\United 16-9-22\"
fichier(2) = "Source.xlsm"
feuille(2) = "PRIX"
cellules(2) = "a1:e52"
GetData chemin(2) & fichier(2), feuille(2), cellules(2), _
ActiveSheet.Range("a1"), True, True

End Sub

 

[AtTheOne]

Bonne nuit à toutes & à tous, bonne nuit @Keiko

Je t'ai bâti un exemple. Pour l'interface j'ai choisi d'utiliser une feuille d'Accueil dans laquelle on renseigne les données nécessaires à l'import. Pour le nom du fichier et le nom de la feuille il y a une "assistance" à découvrir et des validations des données.

J'ai commenté le code pour en faciliter l'appropriation.

Code de la feuille "Accueil" (Sélection du fichier, liste des feuilles) :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
''Early Bindind
'Mettre en référence "Microsoft ActiveX Data Objects x.x Library" et " Microsoft ADO ext x.x for DLL and Security"
'(Outil, Références)
'     Dim Cn As ADODB.Connection
'     Dim oCat As ADOX.Catalog, Feuille As ADOX.Table
'     Set Cn = New ADODB.Connection
'     Set oCat = New ADOX.Catalog
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
'Late Binding
     Dim Cn As Object
     Dim oCat As Object, Feuille As Object
     Set Cn = CreateObject("ADODB.Connection")
     Set oCat = CreateObject("ADOX.Catalog")
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
     Dim NomFeuilles$, MonFich
    
     If Target.Address <> [NomFich].Address Then Exit Sub
     ChDir ThisWorkbook.Path
     MonFich = Application.GetOpenFilename("Fichiers Excel (*.xls;*.xlsx;*.xlsm), *.xls;*.xlsx;*.xlsm", , "Fichier Excel SOURCE")
     If MonFich = False Then
          'Effacer le nom de fichier et la liste des feuilles (validation de données de la cellule "NomFeuille")
          [NomFich].ClearContents
          [NomFeuille].ClearContents
          [NomFich].Offset(0, -1).Select
          With Sh_Accueil.[NomFeuille].Validation
               .Delete
               .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=","
          End With
          Exit Sub
     End If
    
'Ecrire le nom du fichier
     [NomFich].Value = MonFich
     [NomFeuille].Select
'Collecter le nom des feuilles
     '--- Connexion ---
     With Cn
         .Provider = "Microsoft.Jet.OLEDB.4.0"
         .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
             & MonFich & ";Extended Properties=""Excel 12.0;HDR=YES;ReadOnly=True;"""
         .Open
     End With
     Set oCat.ActiveConnection = Cn
    
'Liste des feuilles
     For Each Feuille In oCat.Tables
          TxtFeuil = Replace(Feuille.Name, Chr(39), "")
          If Right(TxtFeuil, 1) = "$" Then NomFeuilles = NomFeuilles & Replace(TxtFeuil, "$", "") & ","
     Next
    
'Validation de la cellule "NomFeuille" = liste des feuilles trouvées
     With [NomFeuille].Validation
          .Delete
          .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=NomFeuilles
     End With
     [NomFeuille].ClearContents
    
'Nb de lignes et de colonnes en fonction du type de fichier
     If Right(MonFich, 4) = ".xls" Then
          LgnMax = 65536
          ColMax = 256
     Else
          LgnMax = 1048576
          ColMax = 16384
     Set Feuille = Nothing
     End If

'Validation des cellules NbLignes et NbColonnes
     With [NbLignes].Validation
          .Delete
          .Add Type:=xlValidateWholeNumber, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="1", Formula2:=LgnMax
     End With
     With [NBColonnes].Validation
          .Delete
          .Add Type:=xlValidateWholeNumber, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="1", Formula2:=ColMax
     End With
    
     Set Feuille = Nothing
     Set oCat = Nothing
     Cn.Close
     Set Cn = Nothing
    
End Sub

Code de la macro d'importation :

Sub ImporterPlageFichierFermé()

'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
''Early Binding
''Mettre "Microsoft Scripting Runtime" en référence (Outil, Références)
'     Dim FSO As New Scripting.FileSystemObject
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
'Late Binding
''Pas de bibliothèque en référence
     Dim FSO As Object
     Set FSO = CreateObject("Scripting.FileSystemObject")
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
     Dim Btn$, Fichier$, Feuille$, Cellule$, Chemin$, Classeur, NbLgn As Long, NbCol As Long, Réf$
     Dim Bouton As Shape
    
'Appel via le bouton obligatoirement
     Btn = ""
     On Error Resume Next
     Btn = Application.Caller
     On Error GoTo 0
     If Btn = "" Then Exit Sub
    
'Message du bouton commence par "Importer la plage $" obligatoirement
     Set Bouton = Sh_Accueil.Shapes("Shp_Importer")
     If Not Bouton.DrawingObject.Caption Like "Importer la plage $*" Then Exit Sub
    
'Lecture des données d'entrée
     Application.ScreenUpdating = False
     With Sh_Accueil
          Fichier = .[NomFich].Cells(1).Value
          Feuille = .[NomFeuille].Value
          Cellule = .[Cell1].Value
          NbLgn = WorksheetFunction.Max(.[NbLignes].Value, 1)
          NbCol = WorksheetFunction.Max(.[NBColonnes].Value, 1)
     End With
    
'Extraction du chemin du fichier à importer et du nom du fichier
     Chemin = FSO.GetParentFolderName(Fichier)
     Classeur = FSO.GetFileName(Fichier)
    
'Référence de la première cellule à importer (référence externe avec nom complet du fichier)
     Réf = "'" & Chemin & "\[" & Classeur & "]" & Feuille & "'!" & Cellule
     'Formule avec gestion des cellules vide (pour ne pas récupérer des zéros à la place des vides)
     Formule = "=IF(ISBLANK(" & Réf & "),""""," & Réf & ")"
     'Nettoyage de la feuille cible
     Sh_Cible.Cells.Clear
     'Formule dans la première cellule
     Sh_Cible.[A1].Formula = Formule
     'Extension de la formule si nécessaire
     If NbLgn > 1 Then Sh_Cible.[A1].AutoFill Destination:=Sh_Cible.[A1].Resize(NbLgn), Type:=xlFillDefault
     If NbCol > 1 Then Sh_Cible.[A1].Resize(NbLgn).AutoFill Destination:=Sh_Cible.[A1].Resize(NbLgn, NbCol), Type:=xlFillDefault
     'Remplacer les formules par les valeurs
     Sh_Cible.[A1].Resize(NbLgn, NbCol).Value = Sh_Cible.[A1].Resize(NbLgn, NbCol).Value
     'Activer la feuille cible
     Application.Goto Sh_Cible.[A1], True
    
     Application.ScreenUpdating = True
     Set FSO = Nothing
     Set Bouton = Nothing

End Sub

Voir le fichier en PJ
Amicalement
Alain

PS si cette proposition répond à tes attentes, pense à marquer ce post en tant que solution.

 

[AtTheOne]

Bonjour @Keiko
As-tu eu le temps de regarder ma proposition ?
Amicalement
Alain

 

[presa54]

Bonjour @Keiko
As-tu eu le temps de regarder ma proposition ?
Amicalement
Alain

Bonjour, je viens de tester le fichier Excel, mais il y a une erreur, dès que je choisis le nom de la feuille source il y a une erreur qui apparaît sur la ligne tout en bas, il affiche "#VALUE!",

Merci

 

[AtTheOne]

Bonne nuit les noctambules !
Bonjour @presa54 et bienvenu !
Waouh ! Après un peu plus de 2 ans ce fil se réactive, mais pas par l'auteur @Keiko qui m'a laissé sans nouvelles ...
J'ai retesté chez moi, cela fonctionne regarde ce gif animé :

Peux-tu donner un peu plus de détail sur la façon dont l'erreur se produit, car là ce n'est pas facile de t'aider.

À bientôt

 

[presa54]

Bonne nuit les noctambules !
Bonjour @presa54 et bienvenu !
Waouh ! Après un peu plus de 2 ans ce fil se réactive, mais pas par l'auteur @Keiko qui m'a laissé sans nouvelles ...
J'ai retesté chez moi, cela fonctionne regarde ce gif animé :
Regarde la pièce jointe 1207231
Peux-tu donner un peu plus de détail sur la façon dont l'erreur se produit, car là ce n'est pas facile de t'aider.

À bientôt

Merci pour ta réponse rapide ! Après deux ans, je dois avouer que ce post reste un véritable trésor. Je suis tombé dessus un peu par hasard en faisant une recherche sur Internet pour transférer des données d’une feuille Excel à une autre. C’est ainsi que j’ai découvert ton travail, et je t'en remercie !

Ta petite vidéo m’a montré que tout fonctionnait parfaitement. Grâce à cela, j’ai pu tester sur un autre PC, et là, tout fonctionne correctement. Je pense donc que le problème vient de mon premier PC, celui sur lequel je travaille habituellement.

Un grand merci A bientot