Je travaille sur plusieurs gros disques reseaux sur lesquels je gére de la
doc (fichier excel, word, txt, eml.....). J'essai de regrouper par theme les
differents documents dans différents repertoires sur 2 disques principaux
F:\ et G:\.
Or mes collégues enregistrent des docs un peu partout, créeant des
repertoires à la volée.(Mon admin refuse de limiter les la creation de
repertoire et de doc).
Je desirerai
1er)sous Excel, repertorier l'enesmble des documents contenu sur les
disques, par repertoire , les archiver sur une feuille.
2eme) Faire une recherche sur un document et avoir automatiquement le lien
pour l'ouverture. Cad, aue j'aurai dans une feuille contenant une liste de
lien
f:\Espace Document Technique\cahier des charges\gestion solution.doc
je voudrais que ce lien puisse etre activé et que le document soit ouvert
directement par l'application necessaire. Et cela pour l'ensemble des
documents (doc, xls, pdf, ppm,eml....)
Apres quoi je ferai un rapport d'impression pour que chacun puisse savoir ou
son stocker les documents necessaires soit un volume de plusieurs milliers !
Si vous avez une solution, je suis preneur !
Ca fonctionne à merveille ! J'ai pas fais gaffe à ta réponse du 7.02.. Merci encore ! Il n'y a pas de aml. Ca prouve s'il en était besoin qu'il faut éviter de
démarrer des fils simultanés.
Merci pour le retour. @+ FxM
Merci a tout le monde ! Si vous avez d'autres soluces je suis preneur !
"FxM" a écrit dans le message de news:
Bonjour,
Pas optimisée pour deux sous, ni testée dans ses limitations mais ca semble marcher. Je te laisse le soin d'adapter les chemins, extensions (. suivi de 3 caractères), noms de feuille, ...
Sub RecupNomsFichiers() Application.StatusBar = "Un moment, SVP ..." Dim arr_disk, Classeurs() As String, i Dim feuille, extensions, disk, nom, a,cel,cellule,contenu
For Each disk In arr_disk If Right(disk, 1) <> "" Then disk = disk & "" With Application.FileSearch .NewSearch .Filename = "*.*" .LookIn = disk .SearchSubFolders = True .Execute With .FoundFiles ReDim Classeurs(1 To .Count, 1 To 1) On Error Resume Next For I = 1 To .Count DoEvents nom = .Item(I) If I Mod 10 = 0 Then Application.StatusBar = nom If InStr(1, UCase(extensions), UCase(Right(.Item(I), 4))) > 0 Then a = a + 1 Classeurs(a, 1) = .Item(I) End If Next I Application.ScreenUpdating = False cel = feuille.Range("A65536").End(xlUp).Offset(1, 0).Address With feuille.Range(cel).Resize(a) .Value = Classeurs .Sort [A1] End With End With End With Next disk
With feuille .Range("A1:" & .Range("A65536").End(xlUp).Address).Select Selection.Sort [A1] For Each cel In Selection cellule = cel.Address contenu = cel.Value Range(cellule).ClearContents ActiveSheet.Hyperlinks.Add Anchor:=Range(cellule), Address:=contenu Next cel End With Application.StatusBar = False End Sub
Pour info, c'est tiré de ma réponse du 07/02 dans le premier fil que tu sembles avoir délaissé.
@+ FxM
BlackStorm wrote:
Merci en tout cas pour ton aide !
Je t'explique comment je procéde, parce que je suis pas doué ! Je crée une macro que j'arrete immédiatement. Puis je selectionne cette macro et je passe en mode modification. Et là j'insere les lignes de
codes
suivantes. ET ca ne marche pas. Je sais que je ne fais pas ce qu'il faut !! Si tu pouvais m'expliquer en détails je te serai infiniment reconnaissant. Autre chose, les lecteurs
que
je veux scanner sont des lecteurs reseau F: et G: Big merci d'avance.
BlackStorm wrote:
Merci FxM
Encore un que Philippe n'aura pas :o)
Ca fonctionne à merveille ! J'ai pas fais gaffe à ta réponse du 7.02..
Merci encore !
Il n'y a pas de aml. Ca prouve s'il en était besoin qu'il faut éviter de
démarrer des fils simultanés.
Merci pour le retour.
@+
FxM
Merci a tout le monde !
Si vous avez d'autres soluces je suis preneur !
"FxM" <fxmanceaux@chello.fr> a écrit dans le message de news:
ugxV8Rw8DHA.1592@TK2MSFTNGP10.phx.gbl...
Bonjour,
Pas optimisée pour deux sous, ni testée dans ses limitations mais ca
semble marcher. Je te laisse le soin d'adapter les chemins, extensions
(. suivi de 3 caractères), noms de feuille, ...
Sub RecupNomsFichiers()
Application.StatusBar = "Un moment, SVP ..."
Dim arr_disk, Classeurs() As String, i
Dim feuille, extensions, disk, nom, a,cel,cellule,contenu
For Each disk In arr_disk
If Right(disk, 1) <> "" Then disk = disk & ""
With Application.FileSearch
.NewSearch
.Filename = "*.*"
.LookIn = disk
.SearchSubFolders = True
.Execute
With .FoundFiles
ReDim Classeurs(1 To .Count, 1 To 1)
On Error Resume Next
For I = 1 To .Count
DoEvents
nom = .Item(I)
If I Mod 10 = 0 Then Application.StatusBar = nom
If InStr(1, UCase(extensions), UCase(Right(.Item(I), 4))) > 0 Then
a = a + 1
Classeurs(a, 1) = .Item(I)
End If
Next I
Application.ScreenUpdating = False
cel = feuille.Range("A65536").End(xlUp).Offset(1, 0).Address
With feuille.Range(cel).Resize(a)
.Value = Classeurs
.Sort [A1]
End With
End With
End With
Next disk
With feuille
.Range("A1:" & .Range("A65536").End(xlUp).Address).Select
Selection.Sort [A1]
For Each cel In Selection
cellule = cel.Address
contenu = cel.Value
Range(cellule).ClearContents
ActiveSheet.Hyperlinks.Add Anchor:=Range(cellule), Address:=contenu
Next cel
End With
Application.StatusBar = False
End Sub
Pour info, c'est tiré de ma réponse du 07/02 dans le premier fil que tu
sembles avoir délaissé.
@+
FxM
BlackStorm wrote:
Merci en tout cas pour ton aide !
Je t'explique comment je procéde, parce que je suis pas doué !
Je crée une macro que j'arrete immédiatement. Puis je selectionne cette
macro et je passe en mode modification. Et là j'insere les lignes de
codes
suivantes.
ET ca ne marche pas.
Je sais que je ne fais pas ce qu'il faut !! Si tu pouvais m'expliquer en
détails je te serai infiniment reconnaissant. Autre chose, les lecteurs
que
je veux scanner sont des lecteurs reseau F: et G:
Big merci d'avance.
Ca fonctionne à merveille ! J'ai pas fais gaffe à ta réponse du 7.02.. Merci encore ! Il n'y a pas de aml. Ca prouve s'il en était besoin qu'il faut éviter de
démarrer des fils simultanés.
Merci pour le retour. @+ FxM
Merci a tout le monde ! Si vous avez d'autres soluces je suis preneur !
"FxM" a écrit dans le message de news:
Bonjour,
Pas optimisée pour deux sous, ni testée dans ses limitations mais ca semble marcher. Je te laisse le soin d'adapter les chemins, extensions (. suivi de 3 caractères), noms de feuille, ...
Sub RecupNomsFichiers() Application.StatusBar = "Un moment, SVP ..." Dim arr_disk, Classeurs() As String, i Dim feuille, extensions, disk, nom, a,cel,cellule,contenu
For Each disk In arr_disk If Right(disk, 1) <> "" Then disk = disk & "" With Application.FileSearch .NewSearch .Filename = "*.*" .LookIn = disk .SearchSubFolders = True .Execute With .FoundFiles ReDim Classeurs(1 To .Count, 1 To 1) On Error Resume Next For I = 1 To .Count DoEvents nom = .Item(I) If I Mod 10 = 0 Then Application.StatusBar = nom If InStr(1, UCase(extensions), UCase(Right(.Item(I), 4))) > 0 Then a = a + 1 Classeurs(a, 1) = .Item(I) End If Next I Application.ScreenUpdating = False cel = feuille.Range("A65536").End(xlUp).Offset(1, 0).Address With feuille.Range(cel).Resize(a) .Value = Classeurs .Sort [A1] End With End With End With Next disk
With feuille .Range("A1:" & .Range("A65536").End(xlUp).Address).Select Selection.Sort [A1] For Each cel In Selection cellule = cel.Address contenu = cel.Value Range(cellule).ClearContents ActiveSheet.Hyperlinks.Add Anchor:=Range(cellule), Address:=contenu Next cel End With Application.StatusBar = False End Sub
Pour info, c'est tiré de ma réponse du 07/02 dans le premier fil que tu sembles avoir délaissé.
@+ FxM
BlackStorm wrote:
Merci en tout cas pour ton aide !
Je t'explique comment je procéde, parce que je suis pas doué ! Je crée une macro que j'arrete immédiatement. Puis je selectionne cette macro et je passe en mode modification. Et là j'insere les lignes de
codes
suivantes. ET ca ne marche pas. Je sais que je ne fais pas ce qu'il faut !! Si tu pouvais m'expliquer en détails je te serai infiniment reconnaissant. Autre chose, les lecteurs
que
je veux scanner sont des lecteurs reseau F: et G: Big merci d'avance.
