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