excel -- word

Le
achille
Bonjour,

j'aimerais savoir comment faire une macro qui pour un répertoire choisi
m'ouvre tous les fichiers du type .doc dont le nom de fichier se termine par
"_PARA.doc" dans le répertoire choisi ainsi que tous les sous répertoires
dans ledit répertoire sélectionné au debut.


merci
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
michdenis
Le #23189971
Bonjour,

Tu colles le code suivant dans un module standard
Tu renseignes comme tu le désires les diverses constantes
avant de lancer la procédure Test.

J'ai supposé que le code était dans Excel. La procédure test
inscrit la liste des fichiers dans une feuille de calcul. Si tu veux
vraiment ouvrir tous ensemble ces fichiers, regarde la procédure
Test1() à la toute fin de ce message. Il est supposé que tu exécutes
la macro à partir d'Excel...

'==================================================== Option Explicit

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * 260
cAlternate As String * 14
End Type

Private Declare Function FindFirstFileA Lib "Kernel32" _
(ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindNextFileA Lib "Kernel32" _
(ByVal hFindfile As Long, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindClose Lib "Kernel32" _
(ByVal hFindfile As Long) As Long

Dim Arr() As String
Dim NbFichiers As Long
Dim FileFindData As WIN32_FIND_DATA
Dim Fichier As String
Dim objFSO As Object, F As Object

'************Constante à définir*************
'Répertoire de départ
Const Repertoire = "C:UsersDMDocuments"

'Dont le nom du fichier se termine ainsi
Const Masque = "*_PARA.doc"

'Nom de la feuille où seront copiés les fichiers
Const NomFeuilleDestination = "Sheet1"

'Première cellule de la plage dans feuille où
'la liste débutera
Const Adr = "B5"

'********************************************

Sub Test()
If Dir(Repertoire, vbDirectory) <> "" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
ReDim Arr(1 To 1)
NbFichiers = 0
Recurse Repertoire
If NbFichiers > 0 Then
Application.ScreenUpdating = False
With Worksheets(NomFeuilleDestination)
With .Range(Adr).Resize(NbFichiers)
.Value = Application.Transpose(Arr)
.Sort .Item(1, 1)
.EntireColumn.AutoFit
End With
End With
Else
MsgBox "Aucun fichier ayant cette extension : " & Masque
End If
Else
MsgBox "Chemin inexistant " & Repertoire
End If
Set objFSO = Nothing
End Sub

Private Sub Recurse(ByVal Chemin As String)
Dim hFindfile As Long
hFindfile = FindFirstFileA(Chemin & "*.*", FileFindData)
FindNextFileA hFindfile, FileFindData
If FindNextFileA(hFindfile, FileFindData) = 0 Then
FindClose hFindfile
Exit Sub
End If
Do
Fichier = Chemin & Left$(FileFindData.cFileName, _
InStr(1, FileFindData.cFileName, vbNullChar) - 1)
If GetAttr(Fichier) And vbDirectory Then
Recurse Fichier & ""
ElseIf Fichier Like Masque Then
NbFichiers = NbFichiers + 1
ReDim Preserve Arr(1 To NbFichiers)
Arr(NbFichiers) = Fichier
End If
Loop While FindNextFileA(hFindfile, FileFindData)
FindClose hFindfile
End Sub
'====================================================
Pour ouvrir à l'écran tous les fichiers :

Sub Test1()
Dim Wd As Object
If Dir(Repertoire, vbDirectory) <> "" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
ReDim Arr(1 To 1)
NbFichiers = 0
Recurse Repertoire
If NbFichiers > 0 Then
Set Wd = CreateObject("Word.Application")
Wd.Visible = True
For Each elt In Arr
Wd.documents.Open elt
End With
Else
MsgBox "Aucun fichier ayant cette extension : " & Masque
End If
Else
MsgBox "Chemin inexistant " & Repertoire
End If
Set objFSO = Nothing
End Sub



MichD
--------------------------------------------
achille
Le #23190491
j ai un message d erreur dans la procedure test1!!!



"michdenis" il7s4c$43i$
Bonjour,

Tu colles le code suivant dans un module standard
Tu renseignes comme tu le désires les diverses constantes
avant de lancer la procédure Test.

J'ai supposé que le code était dans Excel. La procédure test
inscrit la liste des fichiers dans une feuille de calcul. Si tu veux
vraiment ouvrir tous ensemble ces fichiers, regarde la procédure
Test1() à la toute fin de ce message. Il est supposé que tu exécutes
la macro à partir d'Excel...

'==================================================== > Option Explicit

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * 260
cAlternate As String * 14
End Type

Private Declare Function FindFirstFileA Lib "Kernel32" _
(ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindNextFileA Lib "Kernel32" _
(ByVal hFindfile As Long, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindClose Lib "Kernel32" _
(ByVal hFindfile As Long) As Long

Dim Arr() As String
Dim NbFichiers As Long
Dim FileFindData As WIN32_FIND_DATA
Dim Fichier As String
Dim objFSO As Object, F As Object

'************Constante à définir*************
'Répertoire de départ
Const Repertoire = "C:UsersDMDocuments"

'Dont le nom du fichier se termine ainsi
Const Masque = "*_PARA.doc"

'Nom de la feuille où seront copiés les fichiers
Const NomFeuilleDestination = "Sheet1"

'Première cellule de la plage dans feuille où
'la liste débutera
Const Adr = "B5"

'********************************************

Sub Test()
If Dir(Repertoire, vbDirectory) <> "" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
ReDim Arr(1 To 1)
NbFichiers = 0
Recurse Repertoire
If NbFichiers > 0 Then
Application.ScreenUpdating = False
With Worksheets(NomFeuilleDestination)
With .Range(Adr).Resize(NbFichiers)
.Value = Application.Transpose(Arr)
.Sort .Item(1, 1)
.EntireColumn.AutoFit
End With
End With
Else
MsgBox "Aucun fichier ayant cette extension : " & Masque
End If
Else
MsgBox "Chemin inexistant " & Repertoire
End If
Set objFSO = Nothing
End Sub

Private Sub Recurse(ByVal Chemin As String)
Dim hFindfile As Long
hFindfile = FindFirstFileA(Chemin & "*.*", FileFindData)
FindNextFileA hFindfile, FileFindData
If FindNextFileA(hFindfile, FileFindData) = 0 Then
FindClose hFindfile
Exit Sub
End If
Do
Fichier = Chemin & Left$(FileFindData.cFileName, _
InStr(1, FileFindData.cFileName, vbNullChar) - 1)
If GetAttr(Fichier) And vbDirectory Then
Recurse Fichier & ""
ElseIf Fichier Like Masque Then
NbFichiers = NbFichiers + 1
ReDim Preserve Arr(1 To NbFichiers)
Arr(NbFichiers) = Fichier
End If
Loop While FindNextFileA(hFindfile, FileFindData)
FindClose hFindfile
End Sub
'==================================================== >
Pour ouvrir à l'écran tous les fichiers :

Sub Test1()
Dim Wd As Object
If Dir(Repertoire, vbDirectory) <> "" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
ReDim Arr(1 To 1)
NbFichiers = 0
Recurse Repertoire
If NbFichiers > 0 Then
Set Wd = CreateObject("Word.Application")
Wd.Visible = True
For Each elt In Arr
Wd.documents.Open elt
End With
Else
MsgBox "Aucun fichier ayant cette extension : " & Masque
End If
Else
MsgBox "Chemin inexistant " & Repertoire
End If
Set objFSO = Nothing
End Sub



MichD
--------------------------------------------

isabelle
Le #23190621
bonjour achille,

change la pour celle-ci,

Sub Test1()
Dim Wd As Object
Dim elt
If Dir(Repertoire, vbDirectory) <> "" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
ReDim Arr(1 To 1)
NbFichiers = 0
Recurse Repertoire
If NbFichiers > 0 Then
Set Wd = CreateObject("Word.Application")
Wd.Visible = True
For Each elt In Arr
Wd.documents.Open elt
Next
Else
MsgBox "Aucun fichier ayant cette extension : " & Masque
End If
Else
MsgBox "Chemin inexistant " & Repertoire
End If
Set objFSO = Nothing
End Sub

isabelle

Le 2011-03-09 10:14, achille a écrit :
j ai un message d erreur dans la procedure test1!!!

michdenis
Le #23190611
Corrections apportées :

Tu as cependant besoin du reste du code du message précédent.
Ceci ne remplace que la macro originale Test()
'-------------------------------------
Sub Test1()
Dim Wd As Object, Elt As Variant
If Dir(Repertoire, vbDirectory) <> "" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
ReDim Arr(1 To 1)
NbFichiers = 0
Recurse Repertoire
If NbFichiers > 0 Then
Set Wd = CreateObject("Word.Application")
Wd.Visible = True
For Each Elt In Arr
Wd.documents.Open Elt
Next
Else
MsgBox "Aucun fichier ayant cette extension : " & Masque
End If
Else
MsgBox "Chemin inexistant " & Repertoire
End If
Set objFSO = Nothing
End Sub
'-------------------------------------



MichD
--------------------------------------------
"achille" a écrit dans le message de groupe de discussion : 4d77995f$0$5387$



j ai un message d erreur dans la procedure test1!!!



"michdenis" il7s4c$43i$
Bonjour,

Tu colles le code suivant dans un module standard
Tu renseignes comme tu le désires les diverses constantes
avant de lancer la procédure Test.

J'ai supposé que le code était dans Excel. La procédure test
inscrit la liste des fichiers dans une feuille de calcul. Si tu veux
vraiment ouvrir tous ensemble ces fichiers, regarde la procédure
Test1() à la toute fin de ce message. Il est supposé que tu exécutes
la macro à partir d'Excel...

'==================================================== > Option Explicit

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * 260
cAlternate As String * 14
End Type

Private Declare Function FindFirstFileA Lib "Kernel32" _
(ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindNextFileA Lib "Kernel32" _
(ByVal hFindfile As Long, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindClose Lib "Kernel32" _
(ByVal hFindfile As Long) As Long

Dim Arr() As String
Dim NbFichiers As Long
Dim FileFindData As WIN32_FIND_DATA
Dim Fichier As String
Dim objFSO As Object, F As Object

'************Constante à définir*************
'Répertoire de départ
Const Repertoire = "C:UsersDMDocuments"

'Dont le nom du fichier se termine ainsi
Const Masque = "*_PARA.doc"

'Nom de la feuille où seront copiés les fichiers
Const NomFeuilleDestination = "Sheet1"

'Première cellule de la plage dans feuille où
'la liste débutera
Const Adr = "B5"

'********************************************

Sub Test()
If Dir(Repertoire, vbDirectory) <> "" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
ReDim Arr(1 To 1)
NbFichiers = 0
Recurse Repertoire
If NbFichiers > 0 Then
Application.ScreenUpdating = False
With Worksheets(NomFeuilleDestination)
With .Range(Adr).Resize(NbFichiers)
.Value = Application.Transpose(Arr)
.Sort .Item(1, 1)
.EntireColumn.AutoFit
End With
End With
Else
MsgBox "Aucun fichier ayant cette extension : " & Masque
End If
Else
MsgBox "Chemin inexistant " & Repertoire
End If
Set objFSO = Nothing
End Sub

Private Sub Recurse(ByVal Chemin As String)
Dim hFindfile As Long
hFindfile = FindFirstFileA(Chemin & "*.*", FileFindData)
FindNextFileA hFindfile, FileFindData
If FindNextFileA(hFindfile, FileFindData) = 0 Then
FindClose hFindfile
Exit Sub
End If
Do
Fichier = Chemin & Left$(FileFindData.cFileName, _
InStr(1, FileFindData.cFileName, vbNullChar) - 1)
If GetAttr(Fichier) And vbDirectory Then
Recurse Fichier & ""
ElseIf Fichier Like Masque Then
NbFichiers = NbFichiers + 1
ReDim Preserve Arr(1 To NbFichiers)
Arr(NbFichiers) = Fichier
End If
Loop While FindNextFileA(hFindfile, FileFindData)
FindClose hFindfile
End Sub
'==================================================== >
Pour ouvrir à l'écran tous les fichiers :

Sub Test1()
Dim Wd As Object
If Dir(Repertoire, vbDirectory) <> "" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
ReDim Arr(1 To 1)
NbFichiers = 0
Recurse Repertoire
If NbFichiers > 0 Then
Set Wd = CreateObject("Word.Application")
Wd.Visible = True
For Each elt In Arr
Wd.documents.Open elt
End With
Else
MsgBox "Aucun fichier ayant cette extension : " & Masque
End If
Else
MsgBox "Chemin inexistant " & Repertoire
End If
Set objFSO = Nothing
End Sub



MichD
--------------------------------------------

michdenis
Le #23191001
En relisant la procédure, je viens de me rendre compte que cette ligne
de code est totalement inutile que ce soit dans la procédure Test() ou Test1().
C'est une ligne de code que j'ai oubliée d'effacer lorsque j'ai adapté la
procédure à ton usage.

Set objFSO = CreateObject("Scripting.FileSystemObject")

De même, on peut éliminer la ligne de code qui déclare ces 2 variables :
Dim objFSO As Object, F As Object




MichD
--------------------------------------------
"michdenis" a écrit dans le message de groupe de discussion : il876u$2lo$

Corrections apportées :

Tu as cependant besoin du reste du code du message précédent.
Ceci ne remplace que la macro originale Test()
'-------------------------------------
Sub Test1()
Dim Wd As Object, Elt As Variant
If Dir(Repertoire, vbDirectory) <> "" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
ReDim Arr(1 To 1)
NbFichiers = 0
Recurse Repertoire
If NbFichiers > 0 Then
Set Wd = CreateObject("Word.Application")
Wd.Visible = True
For Each Elt In Arr
Wd.documents.Open Elt
Next
Else
MsgBox "Aucun fichier ayant cette extension : " & Masque
End If
Else
MsgBox "Chemin inexistant " & Repertoire
End If
Set objFSO = Nothing
End Sub
'-------------------------------------



MichD
--------------------------------------------
"achille" a écrit dans le message de groupe de discussion : 4d77995f$0$5387$



j ai un message d erreur dans la procedure test1!!!



"michdenis" il7s4c$43i$
Bonjour,

Tu colles le code suivant dans un module standard
Tu renseignes comme tu le désires les diverses constantes
avant de lancer la procédure Test.

J'ai supposé que le code était dans Excel. La procédure test
inscrit la liste des fichiers dans une feuille de calcul. Si tu veux
vraiment ouvrir tous ensemble ces fichiers, regarde la procédure
Test1() à la toute fin de ce message. Il est supposé que tu exécutes
la macro à partir d'Excel...

'==================================================== > Option Explicit

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * 260
cAlternate As String * 14
End Type

Private Declare Function FindFirstFileA Lib "Kernel32" _
(ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindNextFileA Lib "Kernel32" _
(ByVal hFindfile As Long, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindClose Lib "Kernel32" _
(ByVal hFindfile As Long) As Long

Dim Arr() As String
Dim NbFichiers As Long
Dim FileFindData As WIN32_FIND_DATA
Dim Fichier As String
Dim objFSO As Object, F As Object

'************Constante à définir*************
'Répertoire de départ
Const Repertoire = "C:UsersDMDocuments"

'Dont le nom du fichier se termine ainsi
Const Masque = "*_PARA.doc"

'Nom de la feuille où seront copiés les fichiers
Const NomFeuilleDestination = "Sheet1"

'Première cellule de la plage dans feuille où
'la liste débutera
Const Adr = "B5"

'********************************************

Sub Test()
If Dir(Repertoire, vbDirectory) <> "" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
ReDim Arr(1 To 1)
NbFichiers = 0
Recurse Repertoire
If NbFichiers > 0 Then
Application.ScreenUpdating = False
With Worksheets(NomFeuilleDestination)
With .Range(Adr).Resize(NbFichiers)
.Value = Application.Transpose(Arr)
.Sort .Item(1, 1)
.EntireColumn.AutoFit
End With
End With
Else
MsgBox "Aucun fichier ayant cette extension : " & Masque
End If
Else
MsgBox "Chemin inexistant " & Repertoire
End If
Set objFSO = Nothing
End Sub

Private Sub Recurse(ByVal Chemin As String)
Dim hFindfile As Long
hFindfile = FindFirstFileA(Chemin & "*.*", FileFindData)
FindNextFileA hFindfile, FileFindData
If FindNextFileA(hFindfile, FileFindData) = 0 Then
FindClose hFindfile
Exit Sub
End If
Do
Fichier = Chemin & Left$(FileFindData.cFileName, _
InStr(1, FileFindData.cFileName, vbNullChar) - 1)
If GetAttr(Fichier) And vbDirectory Then
Recurse Fichier & ""
ElseIf Fichier Like Masque Then
NbFichiers = NbFichiers + 1
ReDim Preserve Arr(1 To NbFichiers)
Arr(NbFichiers) = Fichier
End If
Loop While FindNextFileA(hFindfile, FileFindData)
FindClose hFindfile
End Sub
'==================================================== >
Pour ouvrir à l'écran tous les fichiers :

Sub Test1()
Dim Wd As Object
If Dir(Repertoire, vbDirectory) <> "" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
ReDim Arr(1 To 1)
NbFichiers = 0
Recurse Repertoire
If NbFichiers > 0 Then
Set Wd = CreateObject("Word.Application")
Wd.Visible = True
For Each elt In Arr
Wd.documents.Open elt
End With
Else
MsgBox "Aucun fichier ayant cette extension : " & Masque
End If
Else
MsgBox "Chemin inexistant " & Repertoire
End If
Set objFSO = Nothing
End Sub



MichD
--------------------------------------------

achille
Le #23203341
bonjour

voici donc le code que j ai mis apres vos conseils et je vous en remercie
Private Declare Function FindClose Lib "Kernel32" _
(ByVal hFindfile As Long) As Long

Dim Arr() As String
Dim NbFichiers As Long
Dim FileFindData As WIN32_FIND_DATA
Dim Fichier As String
Dim objFSO As Object, F As Object

'************Constante à définir*************
'Répertoire de départ
Const Repertoire = "V:"

'Dont le nom du fichier se termine ainsi
Const Masque = ".doc"

'Nom de la feuille où seront copiés les fichiers
Const NomFeuilleDestination = "Sheet1"

'Première cellule de la plage dans feuille où
'la liste débutera
Const Adr = "B5"

'********************************************

Sub Test()
If Dir(Repertoire, vbDirectory) <> "" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
ReDim Arr(1 To 1)
NbFichiers = 0
Recurse Repertoire
If NbFichiers > 0 Then
Application.ScreenUpdating = False
With Worksheets(NomFeuilleDestination)
With .Range(Adr).Resize(NbFichiers)
.Value = Application.Transpose(Arr)
.Sort .Item(1, 1)
.EntireColumn.AutoFit
End With
End With
Else
MsgBox "Aucun fichier ayant cette extension : " & Masque
End If
Else
MsgBox "Chemin inexistant " & Repertoire
End If
Set objFSO = Nothing
End Sub

Private Sub Recurse(ByVal Chemin As String)
Dim hFindfile As Long
hFindfile = FindFirstFileA(Chemin & "*.*", FileFindData)
FindNextFileA hFindfile, FileFindData
If FindNextFileA(hFindfile, FileFindData) = 0 Then
FindClose hFindfile
Exit Sub
End If
Do
Fichier = Chemin & Left$(FileFindData.cFileName, _
InStr(1, FileFindData.cFileName, vbNullChar) - 1)
If GetAttr(Fichier) And vbDirectory Then
Recurse Fichier & ""
ElseIf Fichier Like Masque Then
NbFichiers = NbFichiers + 1
ReDim Preserve Arr(1 To NbFichiers)
Arr(NbFichiers) = Fichier
End If
Loop While FindNextFileA(hFindfile, FileFindData)
FindClose hFindfile
End Sub
'====================================================
'Pour ouvrir à l'écran tous les fichiers :

Sub Test1()
Dim Wd As Object, Elt As Variant
If Dir(Repertoire, vbDirectory) <> "" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
ReDim Arr(1 To 1)
NbFichiers = 0
Recurse Repertoire
If NbFichiers > 0 Then
Set Wd = CreateObject("Word.Application")
Wd.Visible = True
For Each Elt In Arr
Wd.documents.Open Elt
Next
Else
MsgBox "Aucun fichier ayant cette extension : " & Masque
End If
Else
MsgBox "Chemin inexistant " & Repertoire
End If
Set objFSO = Nothing
End Sub



il me marque une msgbox avec aucun fichier avec nom extension .doc ---- avez
vous une solution?
Publicité
Poster une réponse
Anonyme