Prise en compte de fichiers xls quels que soient leurs noms

Nagrom

XLDnaute Occasionnel
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.
 

BrunoM45

XLDnaute Barbatruc
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

XLDnaute Occasionnel
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?
 
Dernière édition:

JNP

XLDnaute Barbatruc
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 :cool:
 

BrunoM45

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

Salut JNP ;)
Bonjour Nagrom

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) :rolleyes:

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

XLDnaute Occasionnel
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.
 

Nagrom

XLDnaute Occasionnel
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.
 

Pièces jointes

  • Excel Download.zip
    40.9 KB · Affichages: 27
  • Excel Download.zip
    40.9 KB · Affichages: 28
  • Excel Download.zip
    40.9 KB · Affichages: 27

JNP

XLDnaute Barbatruc
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 :cool:
 

Staple1600

XLDnaute Barbatruc
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 ?
 

Discussions similaires

Réponses
6
Affichages
326
Réponses
0
Affichages
260

Statistiques des forums

Discussions
299 703
Messages
1 978 596
Membres
206 300
dernier inscrit
gauthier75011