OpenCopyPaste

Evictius · 3 Mai 2018

Bonjour à tous,

Voici ma problématique, je dois récupérer des données qui se trouvent sur différents classeurs et toutes les copier dans un autre classeur.

J'ai glané une partie de code pour que la macro passe sur les fichiers d'un dossier. Cela fonctionne partiellement puisque je vois qu'Excel ouvre chaque fichier mais la macro ne Copie/Colle pas les cellules demandées. J'ai essayé en nommant un fichier pour tester et cela fonctionne.
Je précise que les fichiers sur lesquels je dois récupérer des infos sont nombreux et portent des noms totalement aléatoires mais ils sont tous dans le même dossier.

Je ne sais pas si j'ai été clair mais le code en question est joint dans le fichier.

A votre disposition pour échanger,

Evictius

Lone-wolf · 3 Mai 2018

Bonjour Evictius

Fait un test comme ceci. Copie le code ci-dessous.

VB:

Sub OpenCopyClose()
Dim wb As Workbook
Dim ws As Worksheet
Dim Fso As Object
Dim FsoRepertoire As Object
Dim FsoFichier As Object
Dim strRepertoire As String

    strRepertoire = ThisWorkbook.Path & "\Fichiers\"

    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set FsoRepertoire = Fso.getfolder(strRepertoire)

    For Each FsoFichier In FsoRepertoire.Files

        With FsoFichier
            .Range("BV2:CC300").Copy
        End With

        With ThisWorkbook.Worksheets("Full").Range("A2")
                .PasteSpecial Paste:=xlPasteValues
        End With

        Application.CutCopyMode = False
        Application.DisplayAlerts = False
        FsoFichier.Close False
        ThisWorkbook.Save
    Next

End Sub

Evictius · 3 Mai 2018

Bonjour Lone-Wolf,

Merci de ton aide.

Cela ne fonctionne pas, j'ai une erreur "Chemin d'accès introuvable" sur cette ligne :

Code:

    Set FsoRepertoire = Fso.getfolder(strRepertoire)

Lone-wolf · 3 Mai 2018

Re

Peut-être comme ceci. Sinon il y a une autre façon.

strRepertoire = ThisWorkbook.Path & "\Fichiers"
Set Fso = CreateObject("Scripting.FileSystemObject")
Set FsoRepertoire = Fso.getfolder(strRepertoire & "\")

Dim Fichier As String, Repertoire As String

Repertoire = ThisWorkbook.Path & "\Fichiers\"
Fichier = Dir(Repertoire & "*.xls")
If len(Fichier) > 0 then
Workbooks.Open (Repertoire & Fichier)
End If

Evictius · 3 Mai 2018

Lone-wolf à dit:
Re

Peut-être comme ceci. Sinon il y a une autre façon.

strRepertoire = ThisWorkbook.Path & "\Fichiers"

Set Fso = CreateObject("Scripting.FileSystemObject")
Set FsoRepertoire = Fso.getfolder(strRepertoire & "\")

ça ne fonctionne toujours pas, j'ai pris une partie de ton code pour l'ajouter sur le mien.
Cela donne ça:

VB:

Sub OpenCopyClose1()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim Fso As Object
    Dim FsoRepertoire As Object
    Dim FsoFichier As Object
  
    Dim strRepertoire As String
    strRepertoire = ThisWorkbook.Path & "\Fichiers"
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set FsoRepertoire = Fso.getfolder(ThisWorkbook.Path)
  
For Each FsoFichier In FsoRepertoire.Files
            With FsoFichier
            Range("BV2:CC300").Copy
            End With
          
            With ThisWorkbook.Worksheets("Full").Range("A2")
            .PasteSpecial Paste:=xlPasteValues
            End With
          
            ThisWorkbook.Save
            Application.CutCopyMode = False
           
            Application.DisplayAlerts = False

Next

End Sub

Mais ça ne fonctionne toujours pas. C'est frustrant car je vois dans mon tableau excel que les lignes et rangées sont sélectionnées .

Lone-wolf · 3 Mai 2018

Re

Essaie l'autre méthode.

Lone-wolf · 3 Mai 2018

Re

Je suis bête moi aussi "Range("BV2:CC300").Copy" .Il faut ajouter le nom de la feuille à copier. Là tu ouvre juste le classeur.

Si ils ont la même structure, et si les données sont toutes dans la même feuille, tu peux mettre .Sheets(1).Range("BV2:CC300").Copy.

Regarde le code name de la feuille et non le nom de l'onglet.

Sinon, voici un code de Pierrot93 à adapter

VB:

Option Explicit
Sub test()
Dim Fso As Object, MonRepertoire As String
Dim f1 As Object, f2 As Object, wb As Workbook
Set Fso = CreateObject("Scripting.FileSystemObject")
MonRepertoire = "C:\TEST EXCEL\"
For Each f1 In Fso.GetFolder(MonRepertoire).SubFolders
    For Each f2 In f1.Files
        Set wb = Workbooks.Open(f2)
        'tes instructions
        wb.Close
     Next f2
Next f1
End Sub

Evictius · 3 Mai 2018

Lone-wolf à dit:
Re

Je suis bête moi aussi "Range("BV2:CC300").Copy" .Il faut ajouter le nom de la feuille à copier. Là tu ouvre juste le classeur.

Si ils ont la même structure, et si les données sont toutes dans la même feuille, tu peux mettre .Sheets(1).Range("BV2:CC300").Copy.

Regarde le code name de la feuille et non le nom de l'onglet.

Oui les données sont toutes situées sur la même feuille.
J'ai modifié la ligne de code correspondante.

Les fichiers Excel qui contiennent les informations à copier ne s'ouvrent pas. Je pense que le code actuel se contente de copier coller la feuille du classeur dans lequel j'exécute la macro.

EDIT: après un test, il va récupérer les cellules BV:CC du fichier qui exécute la macro et vient les recoller en A2 en fonction du nombre de fichiers qui se trouvent dans le répertoire.

Lone-wolf · 3 Mai 2018

Re

Fait un test avec le dernier code que j'ai mis.

EDIT: la macro avec modifications

VB:

Option Explicit
Sub test()
Dim Fso As Object, MonRepertoire As String
Dim f1 As Object, f2 As Object, wb As Workbook

Set Fso = CreateObject("Scripting.FileSystemObject")
MonRepertoire = "C:\repD\"

For Each f1 In Fso.GetFolder(MonRepertoire).SubFolders
    For Each f2 In f1.Files
        Set wb = Workbooks.Open(f2)
    
        With wb.Sheets(1)
            .Range("BV2:CC300").Copy ThisWorkbook.Sheets("Full").Range("A" & Rows.Count).End(xlUp)(2)
        End With
        wb.Close False
     Next f2
Next f1
ThisWorkbook.Save
End Sub

Mais maintenant que ça me fait tilt .Range("BV2:CC300").Copy Sheets("Full").Range("A2") ça me paraît faux, car à chaque fois tu écrase les données du précédent classeur.

Avec Range("A" & Rows.Count).End(xlUp)(2), ça vas copier les données à la suite.

Evictius · 3 Mai 2018

Il ne se passe rien

VB:

Sub test()
Dim Fso As Object, MonRepertoire As String
Dim f1 As Object, f2 As Object, wb As Workbook
Set Fso = CreateObject("Scripting.FileSystemObject")
MonRepertoire = "C:\repD\"
For Each f1 In Fso.GetFolder(MonRepertoire).SubFolders
    For Each f2 In f1.Files
        Set wb = Workbooks.Open(f2)
         With f1
            Sheets(1).Range("BV2:CC300").Copy
            End With
         
            With ThisWorkbook.Worksheets("Full").Range("A2")
            .PasteSpecial Paste:=xlPasteValues
            End With
         
            ThisWorkbook.Save
        wb.Close
     Next f2
Next f1
End Sub

Lone-wolf · 3 Mai 2018

Re

C'est faux. Il ne faut pas mettre With f1 mais With wb. Regarde mon dernier post.

Lone-wolf · 3 Mai 2018

Re

Voici la macro test que j'ai éfectué. Dans MonRepertoire il ne faut pas inscrire le dossier contenant les classeurs.

VB:

Option Explicit

Sub test()
Dim Fso As Object, MonRepertoire As String, derlig As Long
Dim f1 As Object, f2 As Object, wb As Workbook

Set Fso = CreateObject("Scripting.FileSystemObject")
MonRepertoire = "C:\repD\"   'Ne pas ajouter le dossier qui contient les classeurs

Application.ScreenUpdating = False

For Each f1 In Fso.GetFolder(MonRepertoire).SubFolders
    For Each f2 In f1.Files
        Set wb = Workbooks.Open(f2)

        With wb.Sheets(1)
             derlig = .Range("a" & Rows.Count).end (xlUp).Row
            .Range("bv2:cc" & derlig).Copy ThisWorkbook.Sheets("Full").Range("a" & Rows.Count).End(xlUp)(2)
        End With
        wb.Close False
     Next f2
Next f1
ThisWorkbook.Save
End Sub

Toutes les données sont inscrites dans le classeur de destination.

Evictius · 3 Mai 2018

Malheureusement, ça ne fonctionne pas.

En parallèle, j'ai fait ce code:

VB:

Sub OpenCopyPaste()

Dim Fichier As String
Dim Chemin As String
Dim wb As Workbook
Dim ws As Worksheet
Dim Fso As Object
Dim FsoRepertoire As Object
Dim FsoFichier As Object
Chemin = "C:\repD\"
Fichier = Dir(Chemin & "*.xlsx")
    Set wb = Workbooks.Open(Chemin & Fichier)
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set FsoRepertoire = Fso.GetFolder(ThisWorkbook.Path)
 
    For Each FsoFichier In FsoRepertoire.Files
          
            With FsoFichier
            Sheets(1).Range("BV2:CC300").Copy
            End With
         
            With ThisWorkbook.Worksheets("Full").Range("A" & Rows.Count).End(xlUp)(2)
            .PasteSpecial Paste:=xlPasteValues
            End With
         
            ThisWorkbook.Save
       
    Next FsoFichier
 
    wb.Close True

    Set wb = Nothing

Fichier = Dir
End Sub

Il fonctionne partiellement puisqu'il copie les données d'un fichier. Ensuite il recopie à la suite les données du même fichier 5 fois (nombre de fichier actuellement dans le dossier) au lieu de copier les données du fichier d'après.

Lone-wolf · 3 Mai 2018

Re

Quelle est ta version Excel?

Evictius · 3 Mai 2018

Effectuez une recherche sur Excel Downloads...

OpenCopyPaste

Evictius

XLDnaute Nouveau

Pièces jointes

Lone-wolf

XLDnaute Barbatruc

Evictius

XLDnaute Nouveau

Lone-wolf

XLDnaute Barbatruc

Evictius

XLDnaute Nouveau

Lone-wolf

XLDnaute Barbatruc

Lone-wolf

XLDnaute Barbatruc

Evictius

XLDnaute Nouveau

Lone-wolf

XLDnaute Barbatruc

Evictius

XLDnaute Nouveau

Lone-wolf

XLDnaute Barbatruc

Lone-wolf

XLDnaute Barbatruc

Evictius

XLDnaute Nouveau

Lone-wolf

XLDnaute Barbatruc

Evictius

XLDnaute Nouveau

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums