Code VBA non fonctionnel

Question

Bonjour, 

je cherche à créer une unique feuille excel dans un nouveau classeur qui reprendrais les données de 200 classeurs excel semblables (1 seule feuille excel, 26 colonnes comportant les mêmes en-têtes mais un nombre de ligne variable selon le fournisseur). J'ai mis tous ces fichiers .xlsx dans un seul dossier à part : C:\Users\Documents\fournisseurs\

J'ai trouvé ce code VBA en fouillant sur internet mais il ne fonctionne pas ? Erreur 1004. 
Quand je décompose, ça bloque à l'étape 7. Le 1er fichier s'ouvre, une copie est créée mais ça s'arrête là

1. Sub recup()
2. Range("A1").Select
3. Chemin = "C:\Users\Documents\fournisseurs\" 
4. Fichier = Dir(Chemin & "*.xlsx")
5. Do While Fichier <> ""
6. Workbooks.Open Filename:=Chemin & Fichier
7. Range("acopier").Copy
8. ThisWorkbook.Activate
9. ActiveSheet.Paste
10. Windows(Fichier).Activate
11. Application.CutCopyMode = False
12. ActiveWorkbook.Close savechanges:=False
13. ThisWorkbook.Activate
14. Range("A65536").End(xlUp).Offset(1, 0).Select
15. Fichier = Dir ' Fichier suivant
16. Loop
17. End Sub

J'ajoute que j'ai quand même fini par ouvrir chaque dossier 1 par 1 pour définir à chaque fois la plage de donnée "acopier" citée à cette étape 7. WTF ?

 Ce sont mes premiers pas dans cet univers. Je crois que j'aurai été plus rapide à copier/coller tout seul mais je m'acharne ! et compte sur vous maintenant …

Merci d'avance !

M-12 · Answer

Bonjour,

Teste comme ceci, la variable Dl définie la dernière ligne de chaque classeur ouvert
Option Explicit

Sub recup()
  Dim Dl%, Chemin$, Fichier$
  Range("A1").Select
  Chemin = "C:\Users\Documents\fournisseurs\"
  Fichier = Dir(Chemin & "*.xlsx")
    Do While Fichier <> ""
      Workbooks.Open Filename:=Chemin & Fichier
      Dl = Range("A" & Rows.Count).End(xlUp).Row 'n° de la dernière ligne non vide de la colonne A
      Range("A1:A" & Dl).Copy 'Sélection de la cellule A2 à la cellule A et dernière ligne (à modifier suivant valeur à copier)
      ThisWorkbook.Activate
      ActiveSheet.Paste
      Windows(Fichier).Activate
      Application.CutCopyMode = False
      ActiveWorkbook.Close savechanges:=False
      ThisWorkbook.Activate
      Range("A65536").End(xlUp).Offset(1, 0).Select
      Fichier = Dir ' Fichier suivant
    Loop
 End Sub

bonobovert · Answer

Si une âme charitable passe par ici… N'hésitez pas, il manque pas grand chose, je suis sur que pour quelqu'un d'expérimenté, c'est une affaire de minute...

f894009 · Answer

Bonjour,

Une facon de faire relativement simple. Sans les entetes, que vous devez avoir sur le classeur collecteur
nom de feuille classeur de donnees a adapter
Sub recup()
    'Application.ScreenUpdating = False  'enlever le ' des que ok
    Chemin = "C:\Users\Documents\fournisseurs\"
    Fichier = Dir(Chemin & "*.xlsx")
    Do While Fichier <> ""
        Workbooks.Open Filename:=Chemin & Fichier
        TN_1 = Worksheets("feuil1").Range("A2:Z" & Range("A" & Rows.Count).End(xlUp).Row)       'mise en memoire
        Workbooks(Fichier).Close False
        Worksheets("feuil2").Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).Resize(UBound(TN_1, 1), UBound(TN_1, 2)) = TN_1
      Fichier = Dir ' Fichier suivant
    Loop
    ThisWorkbook.Save
    Application.ScreenUpdating = True
End Sub

vu le nombre de fichiers (200), il faudrait plutot s'orienter vers une recuperation de donnees classeurs fermes

Code VBA non fonctionnel

3 réponses

Discussions similaires

Newsletters