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
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?
C'est la conséquence du formatage des nombreuses cellules inutiles :-)
nb : Modifier le style "Normal" ne fait absolument pas grossir le fichier.
et je plussoie pour la solution d'Isabelle de la Geôlière
-- JièL plussoyeur
Le 21/09/2015 11:39, Emile63 a écrit :
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?
C'est la conséquence du formatage des nombreuses cellules inutiles :-)
nb : Modifier le style "Normal" ne fait absolument pas grossir le fichier.
et je plussoie pour la solution d'Isabelle de la Geôlière
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?
C'est la conséquence du formatage des nombreuses cellules inutiles :-)
nb : Modifier le style "Normal" ne fait absolument pas grossir le fichier.
et je plussoie pour la solution d'Isabelle de la Geôlière
-- JièL plussoyeur
JièL
Jolie Procédure MichD, je garde sous le coude, c'est bien plus pratique que de recopier tout dans un nouveau classeur (même si je préfère quand même cette solution)
Une question quand même : pourquoi un .Clear puis un .Delete ?
-- JièL 1 thé rot gatif
Le 21/09/2015 11:56, MichD a écrit :
| 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 '------------------------------------
Jolie Procédure MichD, je garde sous le coude, c'est bien plus pratique
que de recopier tout dans un nouveau classeur (même si je préfère quand
même cette solution)
Une question quand même : pourquoi un .Clear puis un .Delete ?
--
JièL 1 thé rot gatif
Le 21/09/2015 11:56, MichD a écrit :
| 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
'------------------------------------
Jolie Procédure MichD, je garde sous le coude, c'est bien plus pratique que de recopier tout dans un nouveau classeur (même si je préfère quand même cette solution)
Une question quand même : pourquoi un .Clear puis un .Delete ?
-- JièL 1 thé rot gatif
Le 21/09/2015 11:56, MichD a écrit :
| 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 '------------------------------------
MichD
C'est un copier-coller d'une procédure déjà en magasin... je ne me souviens pas de la question à laquelle je répondais... mais effectivement tu peux faire disparaître les 2 lignes à avec "Clear".
Et si tu en veux une autre qui fait le même travail... '----------------------------------------------------------------------- Sub NettoyerLignesFantômes()
Dim DL As Long, DC As Integer, Sh As Worksheet
On Error Resume Next For Each Sh In Worksheets DL = DerLig(Sh) + 1 DC = DerCol(Sh) + 1 With Sh .Range(.Cells(DL, "A"), .Cells(DL, .columns.count).End(xlDown)).Delete xlUp .Range(.Cells(1, DC), .Cells(.rows.count, DC).End(xlToRight)).Delete xlUp End With Next ThisWorkbook.save End Sub '---------------------------------- Function DerLig(Sh As Worksheet) On Error Resume Next DerLig = Sh.Cells.Find(What:="*", _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row On Error GoTo 0 End Function '---------------------------------- Function DerCol(Sh As Worksheet) On Error Resume Next DerCol = Sh.Cells.Find(What:="*", _ LookIn:=xlFormulas, _ SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious).Column On Error GoTo 0 End Function '---------------------------------- '-----------------------------------------------------------------------
C'est un copier-coller d'une procédure déjà en magasin... je ne me souviens
pas de la question à laquelle je répondais... mais effectivement tu peux faire
disparaître les 2 lignes à avec "Clear".
Et si tu en veux une autre qui fait le même travail...
'-----------------------------------------------------------------------
Sub NettoyerLignesFantômes()
Dim DL As Long, DC As Integer, Sh As Worksheet
On Error Resume Next
For Each Sh In Worksheets
DL = DerLig(Sh) + 1
DC = DerCol(Sh) + 1
With Sh
.Range(.Cells(DL, "A"), .Cells(DL, .columns.count).End(xlDown)).Delete xlUp
.Range(.Cells(1, DC), .Cells(.rows.count, DC).End(xlToRight)).Delete xlUp
End With
Next
ThisWorkbook.save
End Sub
'----------------------------------
Function DerLig(Sh As Worksheet)
On Error Resume Next
DerLig = Sh.Cells.Find(What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
On Error GoTo 0
End Function
'----------------------------------
Function DerCol(Sh As Worksheet)
On Error Resume Next
DerCol = Sh.Cells.Find(What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
On Error GoTo 0
End Function
'----------------------------------
'-----------------------------------------------------------------------
C'est un copier-coller d'une procédure déjà en magasin... je ne me souviens pas de la question à laquelle je répondais... mais effectivement tu peux faire disparaître les 2 lignes à avec "Clear".
Et si tu en veux une autre qui fait le même travail... '----------------------------------------------------------------------- Sub NettoyerLignesFantômes()
Dim DL As Long, DC As Integer, Sh As Worksheet
On Error Resume Next For Each Sh In Worksheets DL = DerLig(Sh) + 1 DC = DerCol(Sh) + 1 With Sh .Range(.Cells(DL, "A"), .Cells(DL, .columns.count).End(xlDown)).Delete xlUp .Range(.Cells(1, DC), .Cells(.rows.count, DC).End(xlToRight)).Delete xlUp End With Next ThisWorkbook.save End Sub '---------------------------------- Function DerLig(Sh As Worksheet) On Error Resume Next DerLig = Sh.Cells.Find(What:="*", _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row On Error GoTo 0 End Function '---------------------------------- Function DerCol(Sh As Worksheet) On Error Resume Next DerCol = Sh.Cells.Find(What:="*", _ LookIn:=xlFormulas, _ SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious).Column On Error GoTo 0 End Function '---------------------------------- '-----------------------------------------------------------------------
Emile63
MichD: Merci, Trop fort, ta (2ème) solution est plein dans le mille :-)
Obèse: 6'162 Ko Light: 338 ko (Je n'en reviens pas!)
Du coup les procédures précédemment discuté sur ce fil re-fonctionn ent à nouveau et sans problèmes. :-))
Encore merci à tous (tte) à pour votre aide.
Emile
MichD: Merci,
Trop fort, ta (2ème) solution est plein dans le mille :-)
Obèse: 6'162 Ko
Light: 338 ko
(Je n'en reviens pas!)
Du coup les procédures précédemment discuté sur ce fil re-fonctionn ent à nouveau et sans problèmes. :-))
