Prise en compte de fichiers xls quels que soient leurs noms

Nagrom · 18 Août 2010

Bonjour à tous,

J'ai trouvé sur le net ce code qui pourrait m'intéresser:

Code:

Sub synthese()
Dim WBS(1 To 2) As Workbook
Dim C As Range
Dim I As Integer, R As Integer, WB As Integer, DestRow As Integer
Dim strRange As String, F As Variant
Dim TEST As Boolean
Dim NoMoreTeam As Boolean
 
 
'referencer les classeurs
Set WBS(1) = GetObject(ActiveWorkbook.Path & "\1.xls")
Set WBS(2) = GetObject(ActiveWorkbook.Path & "\2.xls")
 
'parcourir les feuilles
Application.ScreenUpdating = False
For WB = 1 To 2
    For Each F In Array("LUNDI", "MARDI", "MERCREDI")
        NoMoreTeam = False
        R = 7
      Do Until NoMoreTeam
            strRange = Replace("H%:S%", "%", CStr(R))
            For Each C In WBS(WB).Sheets(F).Range(strRange)
                If UCase(C) = "X" Then TEST = True
            Next C
            If TEST Then
                WBS(WB).Sheets(F).Rows(R).Copy
                ActiveWorkbook.Sheets(F).Range("B65536").End(xlUp).Offset(1, -1).PasteSpecial
            End If
            R = R + 1
            If WBS(WB).Sheets(F).Cells(R, 2) = "" Then NoMoreTeam = True
            TEST = False
        Loop
 

    Next F
    Set WBS(WB) = Nothing
Next WB
Application.ScreenUpdating = True
 
End Sub

Avec ce code les fichiers sur lesquels on opère sont déclarés au préalable (1.xls et 2.xls). Peut-on le modifier pour qu'il prenne en compte tous les fichiers présents dans le dossier où se trouve le code quelque soit le nom qu'ils peuvent prendre?

Merci.

Compte Supprimé 979 · 18 Août 2010

Re : Prise en compte de fichiers xls quels que soient leurs noms

Bonjour Nagrom,

Essaye peut-être avec ce code

En utilisant le File System Object

Code:

Sub synthese()
  Dim FSO  'As Scripting.FileSystemObject
  Dim SourceFolder  'As Scripting.Folder
  Dim FileItem  'As Scripting.File
  Dim Wbs As Workbook
  Dim C As Range
  Dim R As Integer
  Dim strRange As String, F As Variant
  Dim TEST As Boolean
  Dim NoMoreTeam As Boolean
  Set FSO = CreateObject("Scripting.FileSystemObject")
  Set SourceFolder = FSO.GetFolder(ThisWorkbook.Path)
  'parcourir les feuilles
  Application.ScreenUpdating = False
  For Each FileItem In SourceFolder.Files
    Set Wbs = Workbooks.Open(FileItem)
    For Each F In Array("LUNDI", "MARDI", "MERCREDI")
      NoMoreTeam = False
      R = 7
      Do Until NoMoreTeam
        strRange = Replace("H%:S%", "%", CStr(R))
        For Each C In Wbs.Sheets(F).Range(strRange)
          If UCase(C) = "X" Then TEST = True
        Next C
        If TEST Then
          Wbs.Sheets(F).Rows(R).Copy
          ActiveWorkbook.Sheets(F).Range("B65536").End(xlUp).Offset(1, -1).PasteSpecial
        End If
        R = R + 1
        If Wbs.Sheets(F).Cells(R, 2) = "" Then NoMoreTeam = True
        TEST = False
      Loop
    Next F
    Set Wbs = Nothing
  Next FileItem
  Application.ScreenUpdating = True
End Sub

A+

Nagrom · 19 Août 2010

Re : Prise en compte de fichiers xls quels que soient leurs noms

Bonjour BrunoM45,

Merci pour le code proposé mais j'ai une ereur d'éxecution: "Dépassement de capacité". Le fichier nomé 1.xls s'est ouvert et les données qui s'y trouve ont été copié en répétition jusqu'à la 32 000ème ligne environ. Une idée?

JNP · 19 Août 2010

Re : Prise en compte de fichiers xls quels que soient leurs noms

Bonsoir le fil

,
Bruno ne semblant plus en ligne, je pense que c'est la ligne

Code:

R = R + 1

qui doit être surlignée en débogage...
Essaie de modifier

Code:

Dim R As Long

je pense que le nombre de lignes à traiter est trop important.
Bonne soirée

Compte Supprimé 979 · 19 Août 2010

Re : Prise en compte de fichiers xls quels que soient leurs noms

Salut JNP

Bonjour Nagrom

Nagrom à dit:
Bonjour BrunoM45,
Merci pour le code proposé mais j'ai une ereur d'éxecution: "Dépassement de capacité". Le fichier nomé 1.xls s'est ouvert et les données qui s'y trouve ont été copié en répétition jusqu'à la 32 000ème ligne environ. Une idée?

Non aucune, sans fichier(s) joint(s)

J'ai simplement répondu à ta première question

Peut-on le modifier pour qu'il prenne en compte tous les fichiers présents dans le dossier

Le reste c'est peut-être à toi de voir ce qui se passe ..

A+

Nagrom · 19 Août 2010

Re : Prise en compte de fichiers xls quels que soient leurs noms

Bonjour JNP,

C'est effectivement cette ligne qui est surligné. J'ai la modif porposée, maintenant j'ai l'erreur suivante: Erreur définit par l'application ou par l'objet, et j'ai toujours le copier-coller répétitif.

JNP · 19 Août 2010

Re : Prise en compte de fichiers xls quels que soient leurs noms

Re

,
Comme dit Bruno, sans fichier joint, difficile de savoir ce qui se passe

...
Bonne soirée

Nagrom · 19 Août 2010

Re : Prise en compte de fichiers xls quels que soient leurs noms

Voilà les fichiers qui étaient joints avec le code. Dans le fichier "synthèse" se trouve le code initial dans le module 1 et vos codes respectifs dans les modules 2 et 3.

JNP · 19 Août 2010

Re : Prise en compte de fichiers xls quels que soient leurs noms

Re

,
Après quelques corrections, il me semble que ça fonctionne

Code:

[COLOR=blue]Sub[/COLOR] synthese()
  [COLOR=blue]Dim[/COLOR] FSO [COLOR=green]'As Scripting.FileSystemObject[/COLOR]
  [COLOR=blue]Dim[/COLOR] SourceFolder [COLOR=green]'As Scripting.Folder[/COLOR]
  [COLOR=blue]Dim[/COLOR] FileItem [COLOR=green]'As Scripting.File[/COLOR]
  [COLOR=blue]Dim[/COLOR] Wbs [COLOR=blue]As[/COLOR] Workbook, [COLOR=red]FirstWbs As Workbook[/COLOR]
  [COLOR=blue]Dim[/COLOR] C [COLOR=blue]As[/COLOR] Range
  [COLOR=blue]Dim[/COLOR] R [COLOR=blue]As Long[/COLOR]
  [COLOR=blue]Dim[/COLOR] strRange [COLOR=blue]As String[/COLOR], F [COLOR=blue]As Variant[/COLOR]
  [COLOR=blue]Dim[/COLOR] TEST [COLOR=blue]As Boolean[/COLOR]
  [COLOR=blue]Dim[/COLOR] NoMoreTeam [COLOR=blue]As Boolean[/COLOR]
  [COLOR=red]Set FirstWbs = ThisWorkbook[/COLOR]
  [COLOR=blue]Set[/COLOR] FSO = CreateObject("Scripting.FileSystemObject")
  [COLOR=blue]Set[/COLOR] SourceFolder = FSO.GetFolder(ThisWorkbook.Path)
 [COLOR=green] 'parcourir les feuilles[/COLOR]
  Application.ScreenUpdating = [COLOR=blue]False[/COLOR]
  [COLOR=blue]For Each[/COLOR] FileItem [COLOR=blue]In[/COLOR] SourceFolder.Files
 [COLOR=red] If FileItem.Name <> "Synthèse.xls" Then[/COLOR]
    [COLOR=blue]Set[/COLOR] Wbs = Workbooks.Open(FileItem)
    [COLOR=blue]For Each[/COLOR] F [COLOR=blue]In[/COLOR] Array("LUNDI", "MARDI", "MERCREDI")
      NoMoreTeam = [COLOR=blue]False[/COLOR]
      R = 7
      [COLOR=blue]Do Until[/COLOR] NoMoreTeam
        strRange = Replace("H%:S%", "%", [COLOR=blue]CStr[/COLOR](R))
        [COLOR=blue]For Each[/COLOR] C [COLOR=blue]In[/COLOR] Wbs.Sheets(F).Range(strRange)
          [COLOR=blue]If[/COLOR] UCase(C) = "X" [COLOR=blue]Then[/COLOR] TEST = [COLOR=blue]True[/COLOR]
        [COLOR=blue]Next[/COLOR] C
        [COLOR=blue]If[/COLOR] TEST [COLOR=blue]Then[/COLOR]
          Wbs.Sheets(F).Rows(R).Copy
          [COLOR=red]FirstWbs.Sheets[/COLOR](F).Range("B65536").End(xlUp).Offset(1, -1).PasteSpecial
        [COLOR=blue]End If[/COLOR]
        R = R + 1
        [COLOR=blue]If[/COLOR] Wbs.Sheets(F).Cells(R, 2) = "" [COLOR=blue]Then[/COLOR] NoMoreTeam = [COLOR=blue]True[/COLOR]
        TEST = [COLOR=blue]False[/COLOR]
      [COLOR=blue]Loop[/COLOR]
    [COLOR=blue]Next[/COLOR] F
    [COLOR=blue]Set[/COLOR] Wbs = [COLOR=blue]Nothing[/COLOR]
[COLOR=red]End If[/COLOR]
  [COLOR=blue]Next[/COLOR] FileItem
  Application.ScreenUpdating = [COLOR=blue]True[/COLOR]
[COLOR=blue]End Sub[/COLOR]

L'ActiveWorkbook désignant le dernier fichier ouvert, et le fichier de base n'étant pas exclu de l'extraction.
Dis-nous si c'est OK

.
Bonne soirée

Staple1600 · 19 Août 2010

Re : Prise en compte de fichiers xls quels que soient leurs noms

Bonsoir à tous

Je pense que ce fil pourra de te venir en aide

https://www.excel-downloads.com/threads/recuperer-noms-de-dossier-et-de-fichier.61963/

(j'en profite pour saluer tout le beau monde qui s'y manifesta

)

JNP · 19 Août 2010

Re : Prise en compte de fichiers xls quels que soient leurs noms

Re

,

Staple1600 à dit:
(j'en profite pour saluer tout le beau monde qui s'y manifesta )

Merci pour les autres Jean-Marie

...
A +

Staple1600 · 19 Août 2010

Re : Prise en compte de fichiers xls quels que soient leurs noms

Re

Bonsoir JNP
Je t'inclue évidemment dans le beau monde JNP
(le beau monde des membres émérites (VBA (et/ou formules) d'XLD.)
(Bien que tu te distingues d'icelui pour ton appétence à regexp

)

PS: mon "Bonsoir à tous" (précédent n'oubliait lui personne

)

Nagrom: que penses-tu du "Last modified" évoqué dans le fil que je cite plus bas ?

Nagrom · 29 Août 2010

Re : Prise en compte de fichiers xls quels que soient leurs noms

Bonjour à tous,

Désolé pour la réponse tardive mais j'étais parti en déplacement. Je vous remercie à tous pour votre participation au sujet.

Effectuez une recherche sur Excel Downloads...

Prise en compte de fichiers xls quels que soient leurs noms

Nagrom

XLDnaute Occasionnel

Compte Supprimé 979

Guest

Nagrom

XLDnaute Occasionnel

JNP

XLDnaute Barbatruc

Compte Supprimé 979

Guest

Nagrom

XLDnaute Occasionnel

JNP

XLDnaute Barbatruc

Nagrom

XLDnaute Occasionnel

Pièces jointes

JNP

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

JNP

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

Nagrom

XLDnaute Occasionnel

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums