Fomctiom Dir qui renvoie un fichier qui n'arrive pas à s'ouvrir

Fermé
Zou - 20 juin 2013 à 14:17
Thorak83 Messages postés 1051 Date d'inscription jeudi 20 juin 2013 Statut Membre Dernière intervention 22 décembre 2017 - 20 juin 2013 à 14:29
Bonjour,
Je cherche à faire une synthèse de fiches avec plusieurs informations dans un tableau,
j'écrit le code suivant

Sub Synthese()
Application.ScreenUpdating = False
Cells.Delete
Range("A1") = "Name"
Range("B1") = "Nr."
Range("C1") = "m2"
Range("D1") = "Betroffener Dienst"
Range("E1") = "Block Nr."
Range("F1") = "Etage"
Range("G1") = "ZimmerZahl"
Range("A1:G1").Font.Bold = True


'Recherche des différents fichiers'
' Parcours de tous les fichiers
' -----------------------------
ChDir ThisWorkbook.Path
VPB = Dir(ThisWorkbook.Path & "\*.xlsx")
While Len(VPB) > 0
Workbooks.Open VPB
Dim Name As String
Dim Nr As String
Dim m2 As Integer
Dim BD As String
Dim Block As String
Dim Etage As String
Dim ZZahl As Integer
BD = Worksheets("VBP").Range("L15")
Nr = Worksheets("VBP").Range("P11")
m2 = Worksheets("VBP").Range("P29")
Block = Worksheets("VBP").Range("M13")
Etage = Worksheets("VBP").Range("P13")
ZZahl = Worksheets("VBP").Range("V18")
Workbooks("PVBSammelung.xlsm").Activate
'debut de l'écriture des noms du fichier'
Ligne = ActiveSheet.Range("A65536").End(xlUp).Row + 1
Range("A" & Ligne).Value = VPB
Range("B" & Ligne).Value = Nr
Range("C" & Ligne).Value = m2
Range("D" & Ligne).Value = BD
Range("E" & Ligne).Value = Block
Range("F" & Ligne).Value = Etage
Range("G" & Ligne).Value = ZZahl
Workbooks(VPB).Close
VPB = Dir
Wend

' Fin des travaux
' ---------------
Columns("A:A").Replace ".xlsx", ""
Cells.EntireColumn.AutoFit
Range("A1").Select
LigneTotal = Range("A65536").End(xlUp).Offset(1, 0).Row
Range("A" & LigneTotal) = "TOTAUX :"
Range("C" & LigneTotal).FormulaLocal = "=Somme(C2:C" & LigneTotal - 1 & ")"
Range("C" & LigneTotal).FormulaLocal = "=Somme(C2:C" & LigneTotal - 1 & ")"
Range("G" & LigneTotal).FormulaLocal = "=Somme(G2:G" & LigneTotal - 1 & ")"
Range("A" & LigneTotal & ":G" & LigneTotal).Font.Bold = True
'Mise en formes totaux'
Range("C" & LigneTotal).Borders.LineStyle = wdLineStyleSingle
Range("C" & LigneTotal).Borders.LineStyle = wdLineWidth150pt
Range("G" & LigneTotal).Borders.LineStyle = wdLineStyleSingle
Range("G" & LigneTotal).Borders.LineStyle = wdLineWidth150pt


Application.ScreenUpdating = True

End Sub
A l'endroit en gras, VBA m'annonce aque le fichier est introuvable. Ce qui est étrange c'est que tout marchait bien lorsque je n'avais pas d'instruction chdir mais seulement : dir8*.xlsx). Je precise que tous mes fichiers sont dans le meme dossier y compris celui de synthese sauf qu'il est en xlsm.
Après test, j'constaté aue ça a arreté de marcher parceque VBA cherchait dans le dossier D et nom plus le serveur sur le quel sont présents mes documents. D'ou l'ajout de chdir...
Avez vous une idée pour m'aider svp???



A voir également:

1 réponse

Thorak83 Messages postés 1051 Date d'inscription jeudi 20 juin 2013 Statut Membre Dernière intervention 22 décembre 2017 156
20 juin 2013 à 14:29
Hello
Voici une structure de boucle, qui fonctionne, pour la lecture de fichiers dans un dossier. Reste plus qu'a adapter

  Dim Chemin As String
  Dim Fichiers As String
  Dim VPB As String
  Chemin = ThisWorkbook.path
  Fichiers = Dir(Chemin & "\*.xlsx", vbDirectory)
  Do While (Fichiers <> "")
    VPB = Chemin & "\" & Fichiers
    Workbooks.Open VPB
    Fichiers = Dir
  Loop
0