Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel (re)Sortir l'auteur de fichiers Excel (VBA)

(re)Sortir l'auteur de fichiers Excel (VBA)

34 réponses
Avatar
Emile63
Bonjour =E0 tous,

Je cherche lister sur une feuille XL les fichiers (xl) que j'ai sur certain=
s r=E9pertoires de mon disque dur, avec l'extrait de VBA ci-apr=E8s, et cel=
a fonctionne bien. Aujourd'hui je souhaiterais am=E9liorer ce code pour y f=
aire figurer le nom de l'auteur (s'il y a) en plus des Noms de fichiers, ta=
ille et date que j'ai actuellement.Malheureusement en ajoutant Autor ca ne =
fonctionne pas... :-(
--> Voir ici..
-Quelqu'un aurait la solution =E0 mon probl=E8me? :-)

Merci d'avance pour votre aide!
Emile
------------------------------------------------------

Sub Lit_dossier(ByRef dossier, ByVal niveau, MaListe)
Dim d As Object, f As Object, nom_fich As String

ActiveCell.Value =3D decal(niveau - 1) & dossier.Name & "[" & dossier.Pa=
th & "]"
ActiveCell.Interior.ColorIndex =3D 36
ActiveCell.Offset(1, 0).Select
For Each d In dossier.SubFolders
Lit_dossier d, niveau + 1, MaListe
Next
[A4] =3D "Fichiers"
[B4] =3D "Taille"
--> [C4] =3D "Auteur"
[D4] =3D "Date"
ActiveCell.Offset(1, 0).Select
For Each f In dossier.Files
nom_fich =3D f.Name

If nom_fich Like MaListe Then
ActiveCell =3D decal(niveau) & nom_fich
ActiveCell.Offset(0, 1) =3D f.Size

--> ActiveCell.Offset(0, 2) =3D f.Author <----

ActiveCell.Offset(0, 3).HorizontalAlignment =3D xlRight
ActiveCell.Offset(0, 3).NumberFormat =3D "dd/mm/yyyy hh:mm"
ActiveCell.Offset(0, 3) =3D f.DateLastModified
ActiveCell.Interior.ColorIndex =3D 2
ActiveCell.Offset(1, 0).Select
End If
Next
End Sub
Signaler un problème avec ce contenu

10 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
1 2 3 4
Avatar
JièL
Hello,

Le 18/09/2015 14:30, MichD a écrit :
Au tout début de la procédure avant la ligne "On error resume next", ajoute
ces 2 lignes de code :

Application.EnableEvents = False
Application.ScreenUpdating = False



déjà fait, non ?
On Error Resume Next
...
With Application
...
.EnableEvents = False
.ScreenUpdating = False



--
JièL déjà fé
Avatar
JièL
Hello,

moi ce qui me chiffonne dans cette macro c'est que les mise en forme se
font sur des colonnes entières...

Pourquoi ne pas utiliser "i" qui contient le n° de la dernière ligne
pour faire la mise en forme juste sur la partie importante ?

Mais une question quand même, ça plante au bout de combien de fichier ?
(j'ai l'impression que c'est là le pb)

Et une autre, pourquoi cacher 2 colonnes ?

Encore une : pourquoi ne pas changer le style "normal" pour lui mettre
du verdana 10 directement plutot que de le faire sur une sélection ?

Une autre : à quoi sert le ".Locked = False" ? vu qu'il n'y a pas de
verrouillage de la feuille ?

--
JièL curieux


Le 18/09/2015 13:12, Emile63 a écrit :
Bonjour Isabelle, Je reviens sur cette procédure que tu m'avais
gentiment mise à disposition, car très efficace au début, elle à
beaucoup ralenti son temps d'exécution dernièrement (pour une raison
que j'ignore) et aujourd'hui elle "plante Excel" avec le message
d'erreur suivant: "Excel ne peut pas terminer cette tâche avec les
ressources disponibles. Sélectionnez moins de données ou fermez des
applications"

Evidemment cet avertissement n'est pas très explicite, car même Excel
seul (sans aucune autre application) dans Windows (7) le message
arrive et fini par planter. En réalité il y a en tout une trentaine
de fichiers que je "scanne" dans le répertoire et rapatrie les
items.

J'ai pensé que ce code doit partir en boucle quelque part, mais en le
passant en pas à pas, je ne le détecte pas. Bien que si je fais un
pas à pas énergique, il plante pareille.

Est-ce qu'un oeil expert saurait me dire comment lui donner un peu
d'oxygène, et agiliser son fonctionnement

'CODE: '--------------------------------------------------------- Sub
ListeProprietesFichiers_getDetailsOfTest() 'Nécessite d'activer la
référence Microsoft Shell Controls and Automation Dim objShell As
Shell32.Shell Dim strFileName As Shell32.FolderItem Dim objFolder As
Shell32.Folder Dim Resultat As String, Reponse As String Dim i As
Byte Dim x As Integer Dim Racine As String Dim MaCellule As String

On Error Resume Next MaCellule > ActiveCell.Address(RowAbsolute:úlse, ColumnAbsolute:úlse) With
Application .StatusBar = "Exécution macro...." .EnableEvents = False
.ScreenUpdating = False .DisplayAlerts = False End With Racine > ChoixDossierII() If Racine = "" Then Exit Sub Range("A:I").Clear
Range("A1").Select

Set objShell = CreateObject("Shell.Application") 'Répertoire cible
Set objFolder = objShell.Namespace(Racine)

'boucle sur tous les elements du repertoire For Each strFileName In
objFolder.Items

'la ligne 1 pour les titres de colonne If x <= 0 Then Cells(1, 1) > objFolder.GetDetailsOf(objFolder.Items, 0) Cells(1, 2) > objFolder.GetDetailsOf(objFolder.Items, 1) Cells(1, 3) > objFolder.GetDetailsOf(objFolder.Items, 3) Cells(1, 4) > objFolder.GetDetailsOf(objFolder.Items, 18) Cells(1, 5) > objFolder.GetDetailsOf(objFolder.Items, 20) Cells(1, 6) > objFolder.GetDetailsOf(objFolder.Items, 21) Cells(1, 7) > objFolder.GetDetailsOf(objFolder.Items, 22) Cells(1, 8) > objFolder.GetDetailsOf(objFolder.Items, 23) Cells(1, 9) > objFolder.GetDetailsOf(objFolder.Items, 24)

x = 1 End If

'Pour que les dossiers ne soient pas pris en comptes If
strFileName.isFolder = False Then 'Pour vérifier seulement les
fichiers Excel If Not IsError(Application.Find("Excel",
objFolder.GetDetailsOf(strFileName, 2))) Then x = x + 1 Cells(x, 1) > objFolder.GetDetailsOf(strFileName, 0) Cells(x, 2) > objFolder.GetDetailsOf(strFileName, 1) Cells(x, 3) > objFolder.GetDetailsOf(strFileName, 3) Cells(x, 4) > objFolder.GetDetailsOf(strFileName, 18) Cells(x, 5) > objFolder.GetDetailsOf(strFileName, 20) Cells(x, 6) > objFolder.GetDetailsOf(strFileName, 21) Cells(x, 7) > objFolder.GetDetailsOf(strFileName, 22) Cells(x, 8) > objFolder.GetDetailsOf(strFileName, 23) Cells(x, 9) > objFolder.GetDetailsOf(strFileName, 24) End If End If Next
Range(Selection, Selection.End(xlToRight)).Select With
Selection.Font .Name = "Verdana" .Size = 10 End With With
ActiveWindow .SplitRow = 1 .FreezePanes = True .DisplayGridlines > False End With Range(Selection, Selection.End(xlDown)).Select With
Selection .Locked = False .AutoFilter End With
Columns("A:H").AutoFit Columns("B:H").HorizontalAlignment = xlCenter
Columns("F:G").EntireColumn.Hidden = True With Application .Goto
Reference:¬tiveSheet.Range("A1"), scroll:=True
.Range(MaCellule).Select .DisplayAlerts = True .StatusBar = False
.EnableEvents = True .ScreenUpdating = True End With End Sub Function
ChoixDossierII() If Val(Application.Version) >= 10 Then With
Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName > "C:DocumentsMes Dossiers" .Show If .SelectedItems.Count > 0 Then
ChoixDossierII = .SelectedItems(1) Else ChoixDossierII = "" End If
End With Else ChoixDossierII = InputBox("Confirmer le répertoire?")
End If End Function
'--------------------------------------------------------- Merci
d'avance pour votre aide et éventuelles idées / solutions.

Cordialement,

Emile

Avatar
isabelle
bonjour Emile,

au lieu de formater la feuille via la macro, tu pourrais créer une feuille
modèle pré-formater
et insérer celle-ci en début de macro.

Sheets.Add Before:=Worksheets(1), Type:="C:MonModele.xltx"

isabelle
Avatar
MichD
Essaie comme ceci :



Sub ListeProprietesFichiers_getDetailsOfTest()
'Nécessite d'activer la référence Microsoft Shell Controls and Automation
Dim objShell As Shell32.Shell
Dim strFileName As Shell32.FolderItem
Dim objFolder As Shell32.Folder
Dim Resultat As String, Reponse As String
Dim i As Byte
Dim x As Integer
Dim Racine As String, N As String
Dim MaCellule As String, Sh As Worksheet, Rg As Range


Set Sh = Worksheets("Feuil1") 'Nom onglet feuille où l'action se déroule

Racine = ChoixDossierII()
If Racine = "" Then Exit Sub

With Application
.StatusBar = "Exécution macro...."
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With

With Sh
.Range("A:I").Clear
Set Rg = .Range("A1")
End With

Set objShell = CreateObject("Shell.Application")
'Répertoire cible
Set objFolder = objShell.Namespace(Racine)

'Noms des propriétés sur la ligne 1
With objFolder
Rg = .GetDetailsOf(.Items, 0)
Rg.Offset(, 1) = .GetDetailsOf(.Items, 1)
Rg.Offset(, 2) = .GetDetailsOf(.Items, 3)
Rg.Offset(, 3) = .GetDetailsOf(.Items, 18)
Rg.Offset(, 4) = .GetDetailsOf(.Items, 20)
Rg.Offset(, 5) = .GetDetailsOf(.Items, 21)
Rg.Offset(, 6) = .GetDetailsOf(.Items, 22)
Rg.Offset(, 7) = .GetDetailsOf(.Items, 23)
Rg.Offset(, 8) = .GetDetailsOf(.Items, 24)
End With

'boucle sur tous les elements du repertoire
For Each strFileName In objFolder.Items
'Pour que les dossiers ne soient pas pris en comptes
If strFileName.isFolder = False Then
'Pour vérifier seulement les fichiers Excel
If Not IsError(Application.Find("Excel", objFolder.GetDetailsOf(strFileName, 2))) Then
x = x + 1
xxxx = objFolder.GetDetailsOf(strFileName, 1)
Rg.Offset(x, 0) = objFolder.GetDetailsOf(strFileName, 0)
Rg.Offset(x, 1) = objFolder.GetDetailsOf(strFileName, 1)
Rg.Offset(x, 2) = objFolder.GetDetailsOf(strFileName, 3)
Rg.Offset(x, 3) = objFolder.GetDetailsOf(strFileName, 18)
Rg.Offset(x, 4) = objFolder.GetDetailsOf(strFileName, 20)
Rg.Offset(x, 5) = objFolder.GetDetailsOf(strFileName, 21)
Rg.Offset(x, 6) = objFolder.GetDetailsOf(strFileName, 22)
Rg.Offset(x, 7) = objFolder.GetDetailsOf(strFileName, 23)
Rg.Offset(x, 8) = objFolder.GetDetailsOf(strFileName, 24)
End If
End If
Next

'Formatage de la plage résultat
With Sh.Range("A1").Resize(x, 9)
With .Font
.Name = "Verdana"
.Size = 10
End With
.Locked = False
.AutoFilter
.Columns.AutoFit
End With
Columns("B:H").HorizontalAlignment = xlCenter
Columns("F:G").EntireColumn.Hidden = True

N = ActiveSheet.Name
Sh.Activate
With Application.ActiveWindow
.SplitRow = 1
.FreezePanes = True
.DisplayGridlines = False
End With
Worksheets(N).Activate

With Application
.DisplayAlerts = True
.StatusBar = False
.EnableEvents = True
.ScreenUpdating = True
End With

End Sub

Function ChoixDossierII()
If Val(Application.Version) >= 10 Then
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:DocumentsMes Dossiers"
.Show
If .SelectedItems.Count > 0 Then
ChoixDossierII = .SelectedItems(1)
Else
ChoixDossierII = ""
End If
End With
Else
ChoixDossierII = InputBox("Confirmer le répertoire?")
End If
End Function





"MichD" a écrit dans le message de groupe de discussion : mth072$2pc$

Bonjour,

Au tout début de la procédure avant la ligne "On error resume next", ajoute
ces 2 lignes de code :

Application.EnableEvents = False
Application.ScreenUpdating = False
Avatar
MichD
Dans la procédure modifie ces 2 lignes de code :

Columns("B:H").HorizontalAlignment = xlCenter
Columns("F:G").EntireColumn.Hidden = True

Pour

Sh.Columns("B:H").HorizontalAlignment = xlCenter
Sh.Columns("F:G").EntireColumn.Hidden = True

Le code devient comme ceci :

'-------------------------------------------------------------------------------------
Sub ListeProprietesFichiers_getDetailsOfTest()
'Nécessite d'activer la référence Microsoft Shell Controls and Automation
Dim objShell As Shell32.Shell
Dim strFileName As Shell32.FolderItem
Dim objFolder As Shell32.Folder
Dim Resultat As String, Reponse As String
Dim i As Byte
Dim x As Integer
Dim Racine As String, N As String
Dim MaCellule As String, Sh As Worksheet, Rg As Range


Set Sh = Worksheets("Feuil1") 'Nom onglet feuille où l'action se déroule

Racine = ChoixDossierII()
If Racine = "" Then Exit Sub

With Application
.StatusBar = "Exécution macro...."
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With

With Sh
.Range("A:I").Clear
Set Rg = .Range("A1")
End With

Set objShell = CreateObject("Shell.Application")
'Répertoire cible
Set objFolder = objShell.Namespace(Racine)

'Noms des propriétés sur la ligne 1
With objFolder
Rg = .GetDetailsOf(.Items, 0)
Rg.Offset(, 1) = .GetDetailsOf(.Items, 1)
Rg.Offset(, 2) = .GetDetailsOf(.Items, 3)
Rg.Offset(, 3) = .GetDetailsOf(.Items, 18)
Rg.Offset(, 4) = .GetDetailsOf(.Items, 20)
Rg.Offset(, 5) = .GetDetailsOf(.Items, 21)
Rg.Offset(, 6) = .GetDetailsOf(.Items, 22)
Rg.Offset(, 7) = .GetDetailsOf(.Items, 23)
Rg.Offset(, 8) = .GetDetailsOf(.Items, 24)
End With

'boucle sur tous les elements du repertoire
For Each strFileName In objFolder.Items
'Pour que les dossiers ne soient pas pris en comptes
If strFileName.isFolder = False Then
'Pour vérifier seulement les fichiers Excel
If Not IsError(Application.Find("Excel", objFolder.GetDetailsOf(strFileName, 2))) Then
x = x + 1
xxxx = objFolder.GetDetailsOf(strFileName, 1)
Rg.Offset(x, 0) = objFolder.GetDetailsOf(strFileName, 0)
Rg.Offset(x, 1) = objFolder.GetDetailsOf(strFileName, 1)
Rg.Offset(x, 2) = objFolder.GetDetailsOf(strFileName, 3)
Rg.Offset(x, 3) = objFolder.GetDetailsOf(strFileName, 18)
Rg.Offset(x, 4) = objFolder.GetDetailsOf(strFileName, 20)
Rg.Offset(x, 5) = objFolder.GetDetailsOf(strFileName, 21)
Rg.Offset(x, 6) = objFolder.GetDetailsOf(strFileName, 22)
Rg.Offset(x, 7) = objFolder.GetDetailsOf(strFileName, 23)
Rg.Offset(x, 8) = objFolder.GetDetailsOf(strFileName, 24)
End If
End If
Next

'Formatage de la plage résultat
With Sh.Range("A1").Resize(x, 9)
With .Font
.Name = "Verdana"
.Size = 10
End With
.Locked = False
.AutoFilter
.Columns.AutoFit
End With
Sh.Columns("B:H").HorizontalAlignment = xlCenter
Sh.Columns("F:G").EntireColumn.Hidden = True

N = ActiveSheet.Name
Sh.Activate
With Application.ActiveWindow
.SplitRow = 1
.FreezePanes = True
.DisplayGridlines = False
End With
Worksheets(N).Activate

With Application
.DisplayAlerts = True
.StatusBar = False
.EnableEvents = True
.ScreenUpdating = True
End With

End Sub
'-------------------------------------------------------------------------------------
Function ChoixDossierII()
If Val(Application.Version) >= 10 Then
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:DocumentsMes Dossiers"
.Show
If .SelectedItems.Count > 0 Then
ChoixDossierII = .SelectedItems(1)
Else
ChoixDossierII = ""
End If
End With
Else
ChoixDossierII = InputBox("Confirmer le répertoire?")
End If
End Function
'-------------------------------------------------------------------------------------




"MichD" a écrit dans le message de groupe de discussion : mth072$2pc$

Bonjour,

Au tout début de la procédure avant la ligne "On error resume next", ajoute
ces 2 lignes de code :

Application.EnableEvents = False
Application.ScreenUpdating = False
Avatar
MichD
| déjà fait, non ?

Bien vu ! Tu as une meilleure vue que moi.
Avatar
Emile63
Bonjour à tous,

Merci pour votre participation et pour vos nombreux conseils.
MichD: Je te remercie pour ton code affiné "aux petits oignons" ;-)
Malheureusement pour moi, ça plante toujours...
En fait, et pour répondre à JièL, ça plante dès le début de la boucle sur le répertoire. Prendre note que le répertoire est sur un dis que réseau. Par contre en pas-à-pas, ça passe (40 fichiers).
D'autre part, le code fonctionne dans un nouveau classeur.... :-/
JièL: J'ai pris note de tes questions, et j'ai annulé le Locked ainsi q ue les lignes et les colonnes que je masquais, puisqu'à la fin je ne les utilise plus. :-)
En ce qui concerne le style et la mise en forme, c'est réglé je pense a vec la version de MichD.
Isabelle: Merci pour ta réponse.
La feuille en question fait partie d'un classeur qui compte plusieurs feuil les (15), c'est la raison pour laquelle je préfère la garder et la form ater à mesure.
En définitive, je vous remercie tous pour votre aide. Toutefois j'ai l'im pression que pour une raison ou une autre mon classeur tousse et est sur sa dernière ligne de vie..
Je vais tenter de repartir avec une nouvelle feuille, dans laquelle je copi erai (valeurs) les contenus et formattage, ainsi que les vba, pour voir si par hasard ce ne serrait pas une questions de compatibilités des versions Excel. (c'est une feuille créee le 10 février 1998 avec Office 95 je c rois) Actuellement sur Excel 2007. Peut-être qu'elle à été corrompu .. Je ne sais pas, et je ne sais plus par ou chercher..
Des conseils ou procédure pour bien faire ?
Très bonne journée à tous.
Emile
Avatar
Emile63
Je voulais ajouter que mon fichier fait 6 mo, alors qu'il n'a ni images ni photos... Ceci pourrait expliquer cela ?
- Comment faire pour repasser à un poids plus normal?
Merci encore pour vos idées et solutions.
Avatar
MichD
| Prendre note que le répertoire est sur un disque réseau.

Fais ce test : Copie tous ces fichiers dans un répertoire de ton disque dur local.
Lance la procédure. Est-ce que tu as toujours la même erreur?

Si OUI, lis ce qui suit :


| Malheureusement pour moi, ça plante toujours...

Quelle est la ligne de code de la procédure en surbrillance lorsque la procédure plante?

Dans la procédure, modifie cette ligne de code,
"For Each strFileName In objFolder.Items"

Pour

For Each strFileName In objFolder.Items
'Debug.Print strFileName
Debug.Print strFileName.Path

Et affiche la fenêtre "Exécution" dans le bas de la page de la fenêtre de l'éditeur de code:
raccourci clavier : Ctrl + G

Dans la fenêtre Exécution s'affichera le chemin et le nom du fichier pour tous les items du
répertoire traité.
Cela devrait t'aider à déceler ce qui est problématique dans la procédure...







"Emile63" a écrit dans le message de groupe de discussion :


Bonjour à tous,

Merci pour votre participation et pour vos nombreux conseils.
MichD: Je te remercie pour ton code affiné "aux petits oignons" ;-)
Malheureusement pour moi, ça plante toujours...
En fait, et pour répondre à JièL, ça plante dès le début de la boucle sur le répertoire. Prendre
note que le répertoire est sur un disque réseau. Par contre en pas-à-pas, ça passe (40 fichiers).
D'autre part, le code fonctionne dans un nouveau classeur.... :-/
JièL: J'ai pris note de tes questions, et j'ai annulé le Locked ainsi que les lignes et les colonnes
que je masquais, puisqu'à la fin je ne les utilise plus. :-)
En ce qui concerne le style et la mise en forme, c'est réglé je pense avec la version de MichD.
Isabelle: Merci pour ta réponse.
La feuille en question fait partie d'un classeur qui compte plusieurs feuilles (15), c'est la raison
pour laquelle je préfère la garder et la formater à mesure.
En définitive, je vous remercie tous pour votre aide. Toutefois j'ai l'impression que pour une
raison ou une autre mon classeur tousse et est sur sa dernière ligne de vie..
Je vais tenter de repartir avec une nouvelle feuille, dans laquelle je copierai (valeurs) les
contenus et formattage, ainsi que les vba, pour voir si par hasard ce ne serrait pas une questions
de compatibilités des versions Excel. (c'est une feuille créee le 10 février 1998 avec Office 95 je
crois) Actuellement sur Excel 2007. Peut-être qu'elle à été corrompu.. Je ne sais pas, et je ne sais
plus par ou chercher..
Des conseils ou procédure pour bien faire ?
Très bonne journée à tous.
Emile
Avatar
MichD
| Comment faire pour repasser à un poids plus normal?


'------------------------------------
Sub test()'MichD
Dim Sh As Worksheet, DerLig As Long, DerCol As Integer
Dim ModeCalcul As String

Application.ScreenUpdating = False
ModeCalcul = Application.Calculation
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
On Error Resume Next
For Each Sh In ThisWorkbook.Worksheets
With Sh
If Not IsEmpty(.UsedRange) Then
DerLig = .Cells.Find(What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row

DerCol = .Cells.Find(What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
.Range(.Cells(1, DerCol + 1), .Cells(.Rows.Count, .Columns.Count)).Clear
.Range(.Cells(1, DerCol + 1), .Cells(.Rows.Count, .Columns.Count)).Delete
.Range(.Cells(DerLig + 1, 1), .Cells(.Rows.Count, .Columns.Count)).Clear
.Range(.Cells(DerLig + 1, 1), .Cells(.Rows.Count, .Columns.Count)).Delete
End If
End With
If Err <> 0 Then Err = 0
Next
Application.Calculation = ModeCalcul
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
'------------------------------------
1 2 3 4