Importe données d'un fichier Excel dans un autre fichier Excel

Question

Je dois réaliser une application VBA me permettant de lire les données d'un fichier excel pour les importer dans un autre fichier excel. J'ai réussis à réaliser cette application pour copie et coller les information d'un fichiers textes(CSV), mais cependant je n'arrive pas a réussir pour les fichiers excel. Je vous joins mon fichier ainsi que mon code Mon code est le suivant : Dim ligne_debut As Integer: Dim colonne_debut As Integer: Dim ligne_fin As Integer: Dim colonne_fin As Integer: Dim ligne_enCours As Integer: Dim colonne_enCours As Integer: Private Sub exporter_Click() Dim nom_fichier As String ligne_debut = 2: 'signifie que l'importation des données se fera en cellule B2 colonne_debut = 2: ligne_enCours = ligne_debut: colonne_enCours = colonne_debut Cells.Clear For i = 0 To liste_fichiers.ListCount - 1 lecture (liste_fichiers.List(i)) Next i traitement nom_fichier = Application.GetSaveAsFilename(fileFilter:="Text Files (*.txt),*.txt") sortie.Value = nom_fichier ecriture (nom_fichier) End Sub Private Sub fermer_Click() End Sub Private Sub importer_Click() Dim fichier_choisi As String fichier_choisi = Application.GetOpenFilename("Text Files (*.txt),*.txt", , "Selectionner un fichier CSV") If (LCase(fichier_choisi) &lt;&gt; "faux" And fichier_choisi &lt;&gt; "0") Then liste_fichiers.AddItem (fichier_choisi) End If End Sub Private Sub UserForm_Click() End Sub Private Sub lecture(fichier As String) Dim depart As Integer, position As Integer Dim texte As String, tampon As String Open fichier For Input As #1 Do While Not EOF(1) Line Input #1, texte depart = 1: position = 1 Do While (position &lt;&gt; 0) position = InStr(depart, texte, ";", 1) If position = 0 Then tampon = Mid(texte, depart) Sheets("import").Cells(ligne_enCours, colonne_enCours).Value = tampon Exit Do Else tampon = Mid(texte, depart, position - depart) End If Sheets("import").Cells(ligne_enCours, colonne_enCours).Value = tampon depart = position + 1 colonne_enCours = colonne_enCours + 1 Loop colonne_enCours = colonne_debut ligne_enCours = ligne_enCours + 1 Loop Close #1 End Sub Merci de votre aide, CR...

3GB · Accepted Answer

Oui, sur le papier, ça parait pas mal. Après, je n'ai pas vu les fichiers mais si ça fonctionne pour l'instant, c'est très bien, vous pourrez toujours apporter des améliorations quand vos besoins évolueront et se préciseront...

3GB · Answer

Voici un essai à tester avec un code standard trouvé sur internet, qui a priori, devrait répondre à votre besoin : Sub Utilisation_FileDialog_Ouvrir() Dim objOuvrir As FileDialog Dim objFichiers As FileDialogSelectedItems Dim Wb As Workbook Set objOuvrir = Application.FileDialog(msoFileDialogOpen) With objOuvrir 'Affiche la fenêtre "Ouvrir" .Filters.Clear 'Efface les filtres existants. .Filters.Add "Classeurs Excel", "*.xls; *.xlsx; *.xlsm" 'Définit une liste de filtres pour le champ "Type de fichiers". .Show Set objFichiers = .SelectedItems 'Définit les fichiers sélectionnés End With If not objFichiers.Count = 1 Then Exit Sub 'On sort si aucun fichier n'a été sélectionné Application.ScreenUpdating = False Set Wb = Workbooks.Open(objFichiers(1)) 'traitement Wb.Close False Application.ScreenUpdating = True End Sub Sinon, il suffisait de modifier votre ligne comme ceci : Application.GetOpenFilename("Fichiers Excel (*.xlsx), *.xlsx",,"Sélectionner un fichier Excel") Cdlt...

3GB · Answer

Copier, c'est-à-dire ? en créant un nouvel onglet sur le classeur destinataire ? Dim wbsource as workbook, wbdest as workbook '&lt;&lt;&lt;&lt;MODIF A FAIRE '....code Set wbdest = thisworkbook 'classeur exécutant où sera collée la feuille '&lt;&lt;&lt; ajouter Set wbsource = Workbooks.Open(objFichiers(1)) '&lt;&lt;&lt; MODIF wbsource.sheets(3).copy after:=wbdest.worksheets(wbdest.worksheets.count) 'copie feuille 3 source à la fin du classeur dest wbsource.Close False...

3GB · Answer

Ici, avec mon dernier code, vous récupérez la feuille à la position 3 (entière) du fichier sélectionné sur la boite de dialogue sur votre fichier courant (elle se place en dernière position)...

3GB · Answer

Et bien, expliquez moi précisément votre besoin, en détaillant les éléments significatifs (index de la feuille dont le contenu est à copier, nom de la feuille de destination, éventuellement plage de destination), comme ça on pourra tomber juste sans avoir à réévaluer le besoin...

3GB · Answer

Pas la peine de s'excuser autant, c'est pas grave...

Alors c'est clair mais il demeure juste la question de la référence de la plage à copier et celle de la plage à recevoir. Alors dans le doute, je vous propose un essai assez générique que vous pourrez adapter selon votre besoin précis :

Sub Utilisation_FileDialog_Ouvrir()

Dim objOuvrir As FileDialog
Dim objFichiers As FileDialogSelectedItems
Dim wbsource as workbook, wbdest as workbook

Set objOuvrir = Application.FileDialog(msoFileDialogOpen)

With objOuvrir 'Affiche la fenêtre "Ouvrir"
    .Filters.Clear 'Efface les filtres existants.
    .Filters.Add "Classeurs Excel", "*.xls; *.xlsx; *.xlsm" 'Définit une liste de filtres pour le champ "Type de fichiers".
    .Show
    Set objFichiers = .SelectedItems 'Définit les fichiers sélectionnés
End With

If not objFichiers.Count = 1 Then Exit Sub 'On sort si aucun fichier n'a été sélectionné

Application.ScreenUpdating = False

Set wbdest = thisworkbook 'classeur exécutant où sera collée la feuille
Set wbsource = Workbooks.Open(objFichiers(1))

wbsource.sheets("Villes").usedrange.copy destination:=wbdest.Sheets("informations").range("A1") '<<<<ADAPTER
wbsource.Close False

Application.ScreenUpdating = True

End Sub

C'est un début...

Et je retouche un petit peu votre autre macro pour l'alléger :

Sub Rectangleàcoinsarrondis1_Cliquer()

Dim wb As Workbook
Dim sh As Worksheet, dsh As Worksheet
Dim n&, I&, j&
Dim arr

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'application pour ouvrir les fichier
arr = Application.GetOpenFilename(filefilter:="excel files, *.xls*", Title:="open excel files", MultiSelect:=True)
if typename(arr) = "Boolean" then exit sub

'On Error GoTo Fin
Set sh = ThisWorkbook.Sheets("Armoire") 'Affecter une valeur à la variable

With sh
    ligne_collage = .Range("A" & .Rows.Count).End(xlUp).Row + 1 '<<<< ???? (colonne R ?) premiere non vide en A
    .Range("A3:BZ" & .rows.count).ClearContents 'effacer le contenu des colonnes
    For I = LBound(arr) To UBound(arr)
        ligne_collage = .Range("A" & .Rows.Count).End(xlUp).Row + 2
        Set wb = Workbooks.Open(arr(I)) 'Affecter une valeur- le classeur source
        Set dsh = wb.Sheets(1) 'la feuille dans le classeur source
        nbl_copier = dsh.Range("B" & dsh.Rows.Count).End(xlUp).Row 'derniere ligne tableau dans la feuille source
        dsh.Range("A3:BT" & nbl_copier).Copy .Range("A" & ligne_collage) 'copier et coller le tableau dans la feuille source
        wb.Close False
        Set dsh = Nothing
        Set wb = Nothing
    Next I
End with

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Fin:
End Sub

3GB · Answer

Oui, enfin les 2 plages. Si ce n'est pas toute la zone utilisée que vous voulez copier, alors il faudra remplacer usedrange par la range à cibler. Et pour la plage de destination, il faut juste adapter. En vous inspirant de votre première macro, ça devrait aller je pense...

3GB · Answer

Oui, c'est normal parce que votre problème initial concernait la procédure avec l'onglet Villes. J'ai donc considéré qu'il s'agissait de 2 procédures distinctes. La première procédure se comporte indifféremment avec les fichiers sélectionnés et va prendre les données de la feuille 1. La seconde est plus précise car elle prend les données de la feuille Villes (n°3). Il y a plusieurs options : AVEC UNE SEULE BOITE DE DIALOGUE (sans sélectionner le fichier Jules) : - si vous connaissez le nom du fichier (Jules dans votre exemple) et qu'il ne changera pas, alors on peut se passer de boite de dialogue et importer les données directement en ciblant son chemin (ce serait l'idéal), - s'il s'agit d'un fichier émanant d'un modèle de fichiers périodiques et évolutifs, alors c'est plus compliqué mais toujours possible si ces fichiers ont un modèle commun (une partie du chemin et une partie du nom - ex : "C:\2019\Jules 2019.xlsx", "C:\2020\Jules 2020.xlsx"). AVEC UNE SEULE BOITE DE DIALOGUE (en sélectionnant le fichier Jules) : - sinon, s'il n'y a pas de dénominateur commun mais que vos fichiers de la première procédure ne contiennent qu'un unique onglet, on peut dire que si nombre d'onglets &gt; 1 alors on prend les données de l'onglet Villes. AVEC 2 BOITES DE DIALOGUE : - sinon, si on arrive pas à trouver une solution parmi les précédentes, je peux réorganiser le code mais je pense qu'il faudra faire avec 2 boites de dialogue... Pour la copie, je ne peux pas m'avancer pour l'instant car je ne sais pas comment vous avez modifié le code. Dans la nouvelle procédure , on avait : wbsource.sheets("Villes").usedrange.copy destination:=wbdest.Sheets("informations").range("A1") '&lt;&lt;&lt;&lt;ADAPTER J'avais prévu de copier la zone utilisée (et de coller en A1 de la destination). Si la zone utilisée s'arrête en AK, c'est normal. Si vous voulez aller jusqu'à BZ, il faut mettre (c'est un exemple car je ne sais pas quelles lignes vous prendrez) : wbsource.sheets("Villes").range("A1:BZ5000").copy destination:=wbdest.Sheets("informations").range("A1") '&lt;&lt;&lt;&lt;ADAPTER Dans votre ancienne procédure : dsh.Range("A3:BT" & nbl_copier).Copy .Range("A" & ligne_collage) 'copier et coller le tableau dans la feuille J'ai juste compacté les quelques 60 lignes de code répétant l'opération de copier/coller pour chaque colonne en une seule. Je ne crois pas avoir modifié quoi que ce soit. Mais si vous voulez prendre jusqu'à BZ, alors modifiez ainsi : dsh.Range("A3:BZ" & nbl_copier).Copy .Range("A" & ligne_collage) 'copier et coller le tableau dans la feuille Mais il n'y a aucune raison de se retrouver sans les colonnes AL à BT, à moins que vous ayez changé quelque chose...