synthese de plusieurs fichiers identique dans un répertoire dans une seule feuille

[pierro77]

Bonjour à tous,

Je suis débutant en VBA et je souhaite mettre en place une macro qui me permettrait de récupérer des infos dans des classeurs Excel identiques dans un même répertoire pour faire une seule feuille récapitulative où j'accède rapidement à tous mes résutats.
Pour l'instant, j'ai réalisé une macro qui a fonctionnée une fois et puis plus rien. J'ai une erreur 404 qui apparait et qui me dit que les fichiers à ouvrir sont introuvables alors qu'ils sont bien dans le bon répertoire. Je voudrais savoir si quelqu'un a déjà eu ce problème et s'il y a un moyen d'y remédier parce que je m'arrache les cheveux.
Voici ma macro :

Sub consolide()
    Cells.Delete
    ChDir ActiveWorkbook.Path
    Set Synthese = ActiveWorkbook
    Application.ScreenUpdating = False
        compteur = 1
 
  nf = Dir("C:\WINNT\Profiles\pchaza18\Desktop\fitting en cours\*.xls")
  Do While nf <> ""
    If nf <> Synthese.Name Then
      Workbooks.Open Filename:=nf
      Synthese.Sheets(1).Cells(compteur, 1) = Workbooks(nf).Sheets("Resultats").Range("D50").Value
      Synthese.Sheets(1).Cells(compteur, 2) = Workbooks(nf).Sheets("Resultats").Range("D66").Value
      Synthese.Sheets(1).Cells(compteur, 3) = Workbooks(nf).Sheets("Resultats").Range("D53").Value
      compteur = compteur + 1
      Workbooks(nf).Close False
    End If
    nf = Dir
  Loop
  Synthese.Sheets(1).Rows(1).Insert Shift:=xlToRight
  Synthese.Sheets(1).Columns("A:A").Insert Shift:=xlToRight
  Range("B1") = "Chaussure testée"
  Range("C1") = "Nombre de fitting fait"
  Range("D1") = "Sample Type"
  Range("B1:D1").Interior.Color = 13434879
  Range("B1:D1").Font.Bold = True
  Range("B1:D1").Font.Size = 12
  Sheets(1).Cells.HorizontalAlignment = xlCenter
  Sheets(1).Cells.VerticalAlignment = xlCenter
   Application.ScreenUpdating = True
End Sub

Merci pour votre aide précieuse

 

[laurent950]

Re : synthese de plusieurs fichiers identique dans un répertoire dans une seule feuil

Bonsoir,

voici la correction

Sub consolide()
     Cells.Delete  
 ' Cells.Delete = 
 ' Pourquoi détruire la cellule actcive  c'est la ligne de titre ? pourquoi pas
 ' pas commencer le compteur a 2 et garder la lgne de titre ?
    
 ChDir ActiveWorkbook.Path
     Set Synthese = ActiveWorkbook
     Application.ScreenUpdating = False
         compteur = 1
  
  nf = Dir("C:\WINNT\Profiles\pchaza18\Desktop\fitting en cours\*.xls")
   Do While nf <> ""
     If nf <> Synthese.Name Then
       Fichier = "C:\WINNT\Profiles\pchaza18\Desktop\fitting en cours\" & nf
       Workbooks.Open (Fichier) 'Workbooks.Open Filename:=nf
       Synthese.Sheets(1).Cells(compteur, 1) = Workbooks(nf).Sheets("Resultats").Range("D50").Value
       Synthese.Sheets(1).Cells(compteur, 2) = Workbooks(nf).Sheets("Resultats").Range("D66").Value
       Synthese.Sheets(1).Cells(compteur, 3) = Workbooks(nf).Sheets("Resultats").Range("D53").Value
       compteur = compteur + 1
       Workbooks(nf).Close False
     End If
     nf = Dir
   Loop
   Synthese.Sheets(1).Rows(1).Insert Shift:=xlToRight
   Synthese.Sheets(1).Columns("A:A").Insert Shift:=xlToRight
   Range("B1") = "Chaussure testée"
   Range("C1") = "Nombre de fitting fait"
   Range("D1") = "Sample Type"
   Range("B1:D1").Interior.Color = 13434879
   Range("B1:D1").Font.Bold = True
   Range("B1:D1").Font.Size = 12
   Sheets(1).Cells.HorizontalAlignment = xlCenter
   Sheets(1).Cells.VerticalAlignment = xlCenter
    Application.ScreenUpdating = True
 End Sub

Au plaisir de vous lire

Laurent

 

[pierro77]

Re : synthese de plusieurs fichiers identique dans un répertoire dans une seule feuil

Merci beaucoup pour votre réponse. Ca marche comme sur des roulettes.