Diminuer le poids

Re
Quant au répertoire, c'est celui qui est indiqué dans la propriété d'un
fichier qui se trouve dans le répertoire à faire maigrir.

J'ai changé Répertoire par Chemin comme suggéré.


Sub Poids_diminuer(DocName As String)
Set Wk = Workbooks.Open(DocName)

Il me bloque sur ces 2 lignes;

Je suis trop con pour faire fonctionner une macro, alors pas de panique.
Puisque le PC n'en veut pas, ben, qu'il porte ses Kg!

Merci pour ta patience.
mais, ne t'arrache pas les cheveux pour cela. Quelques octets de + ou de -
ne tueront pas. -))


Jacquouille

" Le vin est au repas ce que le parfum est à la femme."
"MichD" a écrit dans le message de groupe de discussion :
mtu6bg$bf4$1@speranza.aioe.org...

Dans ton message précédent, le chemin que tu indiques est probablement pas
bon!

Dans l'explorateur de fichiers Windows, tu as dans le haut de la fenêtre,
une barre
indiquant le chemin du répertoire courant en cours. Est-ce que le chemin
indiqué dans
cette barre est le même que celui indiqué dans la procédure sans oublier de
terminer
le chemin par un "" à la fin du chemin dans la procédure. Dans la procédure
suivante,
il y a une ligne de code qui vérifie si le chemin existe vraiment.
If Dir(Répertoire, vbDirectory) <> "" Then
Dans ton cas, remplace Répertoire par la variable "Chemin".

La procédure qui suit, traite tous les fichiers "Excel" du répertoire
indiqué dabs la procédure
"TEST"
PLUS tous les fichiers Excel des sous-répertoires du répertoire principal.

Il faut éviter de vouloir scanner tout le disque dur!


Option Explicit
'--------------------------------------------------------------------------------
Sub test()
Dim Répertoire As String, MaListe As Variant
Dim Temp(), Elt As Variant, A As Long, ModeCalcul As Long
Dim Sh As Worksheet, Fichier As String

Application.ScreenUpdating = False
ModeCalcul = Application.Calculation
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

'Répertoire de départ à définir...
Répertoire = "C:UsersDenisDocuments"

Fichier = Dir(Répertoire & "*.xl*")

On Error Resume Next
If Dir(Répertoire, vbDirectory) <> "" Then
Do While Fichier = ""
Call Poids_diminuer(Répertoire & Fichier)
Fichier = Dir()
Loop

MaListe = ListeDossiers(Répertoire, Temp())
Erase Temp

For Each Elt In MaListe
Fichier = Dir(Répertoire & Elt & "" & "*.xl*")
Do While Fichier <> ""
Call Poids_diminuer(Répertoire & Fichier)
Fichier = Dir()
Loop
Next
Else
Msgbox "Répertoire non valide """ & répertoire & """."
End If

Application.Calculation = ModeCalcul
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
'--------------------------------------------------------------------------------
Sub Poids_diminuer(DocName As String)
Dim Sh As Worksheet, DerLig As Long
Dim Wk As Workbook, DerCol As Integer

Set Wk = Workbooks.Open(DocName)

On Error Resume Next
For Each Sh In Wk.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)).Delete
.Range(.Cells(DerLig + 1, 1), .Cells(.Rows.Count,
.Columns.Count)).Delete
End If
End With
If Err <> 0 Then Err = 0
Next
Application.DisplayAlerts = False
Wk.Close True
Application.DisplayAlerts = True
Set Wk = Nothing
End Sub
'--------------------------------------------------------------------------------

Function ListeDossiers(dossier, Liste())
Dim Fs As Object, F As Object
Dim F1 As Object, Sf As Object, A As Integer
Set Fs = CreateObject("Scripting.FileSystemObject")
Set F = Fs.GetFolder(dossier)
Set Sf = F.SubFolders

For Each F1 In Sf
ReDim Preserve Liste(0 To A)
Liste(A) = F1.Name
A = A + 1
Next
ListeDossiers = Liste
Erase Liste
End Function
'--------------------------------------------------------------------------------


---
L'absence de virus dans ce courrier électronique a été vérifiée par le logiciel antivirus Avast.
http://www.avast.com

Quand je dis trop con pour ..., c'est évidement de mon PC que je parle. -))



Jacquouille

" Le vin est au repas ce que le parfum est à la femme."
"Jacquouille" a écrit dans le message de groupe de discussion :
mtuel9$mk$1@speranza.aioe.org...

Re
Quant au répertoire, c'est celui qui est indiqué dans la propriété d'un
fichier qui se trouve dans le répertoire à faire maigrir.

J'ai changé Répertoire par Chemin comme suggéré.


Sub Poids_diminuer(DocName As String)
Set Wk = Workbooks.Open(DocName)

Il me bloque sur ces 2 lignes;

Je suis trop con pour faire fonctionner une macro, alors pas de panique.
Puisque le PC n'en veut pas, ben, qu'il porte ses Kg!

Merci pour ta patience.
mais, ne t'arrache pas les cheveux pour cela. Quelques octets de + ou de -
ne tueront pas. -))


Jacquouille

" Le vin est au repas ce que le parfum est à la femme."
"MichD" a écrit dans le message de groupe de discussion :
mtu6bg$bf4$1@speranza.aioe.org...

Dans ton message précédent, le chemin que tu indiques est probablement pas
bon!

Dans l'explorateur de fichiers Windows, tu as dans le haut de la fenêtre,
une barre
indiquant le chemin du répertoire courant en cours. Est-ce que le chemin
indiqué dans
cette barre est le même que celui indiqué dans la procédure sans oublier de
terminer
le chemin par un "" à la fin du chemin dans la procédure. Dans la procédure
suivante,
il y a une ligne de code qui vérifie si le chemin existe vraiment.
If Dir(Répertoire, vbDirectory) <> "" Then
Dans ton cas, remplace Répertoire par la variable "Chemin".

La procédure qui suit, traite tous les fichiers "Excel" du répertoire
indiqué dabs la procédure
"TEST"
PLUS tous les fichiers Excel des sous-répertoires du répertoire principal.

Il faut éviter de vouloir scanner tout le disque dur!


Option Explicit
'--------------------------------------------------------------------------------
Sub test()
Dim Répertoire As String, MaListe As Variant
Dim Temp(), Elt As Variant, A As Long, ModeCalcul As Long
Dim Sh As Worksheet, Fichier As String

Application.ScreenUpdating = False
ModeCalcul = Application.Calculation
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

'Répertoire de départ à définir...
Répertoire = "C:UsersDenisDocuments"

Fichier = Dir(Répertoire & "*.xl*")

On Error Resume Next
If Dir(Répertoire, vbDirectory) <> "" Then
Do While Fichier = ""
Call Poids_diminuer(Répertoire & Fichier)
Fichier = Dir()
Loop

MaListe = ListeDossiers(Répertoire, Temp())
Erase Temp

For Each Elt In MaListe
Fichier = Dir(Répertoire & Elt & "" & "*.xl*")
Do While Fichier <> ""
Call Poids_diminuer(Répertoire & Fichier)
Fichier = Dir()
Loop
Next
Else
Msgbox "Répertoire non valide """ & répertoire & """."
End If

Application.Calculation = ModeCalcul
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
'--------------------------------------------------------------------------------
Sub Poids_diminuer(DocName As String)
Dim Sh As Worksheet, DerLig As Long
Dim Wk As Workbook, DerCol As Integer

Set Wk = Workbooks.Open(DocName)

On Error Resume Next
For Each Sh In Wk.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)).Delete
.Range(.Cells(DerLig + 1, 1), .Cells(.Rows.Count,
.Columns.Count)).Delete
End If
End With
If Err <> 0 Then Err = 0
Next
Application.DisplayAlerts = False
Wk.Close True
Application.DisplayAlerts = True
Set Wk = Nothing
End Sub
'--------------------------------------------------------------------------------

Function ListeDossiers(dossier, Liste())
Dim Fs As Object, F As Object
Dim F1 As Object, Sf As Object, A As Integer
Set Fs = CreateObject("Scripting.FileSystemObject")
Set F = Fs.GetFolder(dossier)
Set Sf = F.SubFolders

For Each F1 In Sf
ReDim Preserve Liste(0 To A)
Liste(A) = F1.Name
A = A + 1
Next
ListeDossiers = Liste
Erase Liste
End Function
'--------------------------------------------------------------------------------


---
L'absence de virus dans ce courrier électronique a été vérifiée par le
logiciel antivirus Avast.
http://www.avast.com


---
L'absence de virus dans ce courrier électronique a été vérifiée par le logiciel antivirus Avast.
http://www.avast.com

Dans la procédure "Test", tu as 2 variables à définir

A ) Le répertoire que tu veux traiter

et

B ) Si tu désires traiter les sous-répertoires de ce répertoire en même temps.

Évidemment, si certains classeurs requièrent un mot de passe pour ouvrir le classeur,
il te sera demandé en cours d'exécution.


Option Explicit

Dim ShR As Worksheet, Compteur As Long
'--------------------------------------------------------------------------------

Sub test()
Dim Répertoire As String, MaListe As Variant
Dim Temp(), Elt As Variant, A As Long, ModeCalcul As Long
Dim Sh As Worksheet, Fichier As String, SousRep As Boolean
Dim UpLink As Boolean, IgRequest As Boolean

Application.ScreenUpdating = False
ModeCalcul = Application.Calculation
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
UpLink = Application.AskToUpdateLinks
IgRequest = Application.IgnoreRemoteRequests
Application.IgnoreRemoteRequests = True

Application.AskToUpdateLinks = False


'**************Répertoire de départ à définir**********
Répertoire = "C:UsersDenisDocuments"
'Pour inclure les répertoire, attribue True à la variable suivante:
SousRep = True 'Or False
'*******************************************************

Fichier = Dir(Répertoire & "*.xl*")

Compteur = 0

On Error Resume Next
If Dir(Répertoire, vbDirectory) <> "" Then
Application.DisplayAlerts = False
Worksheets("Liste des fichiers").Delete
Set ShR = Worksheets.Add
ShR.Name = "Liste des fichiers"

Do While Fichier <> ""
If Répertoire & Fichier <> ThisWorkbook.FullName Then
Call Poids_diminuer(Répertoire & Fichier)
Fichier = Dir()
End If
Loop

If SousRep = True Then
MaListe = ListeDossiers(Répertoire, Temp(), SousRep)
Erase Temp

For Each Elt In MaListe
Fichier = Dir(Répertoire & Elt & "" & "*.xl*")
Do While Fichier <> ""
If Répertoire & Elt & "" & Fichier <> ThisWorkbook.FullName Then
Call Poids_diminuer(Répertoire & Elt & "" & Fichier)
Fichier = Dir()
End If
Loop
Next
End If
Else
MsgBox "Répertoire non valide """ & Répertoire & """."
End If
Application.IgnoreRemoteRequests = IgRequest
Application.AskToUpdateLinks = UpLink
Application.Calculation = ModeCalcul
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
'--------------------------------------------------------------------------------
Sub Poids_diminuer(DocName As String)
Dim Sh As Worksheet, DerLig As Long
Dim Wk As Workbook, DerCol As Integer

Set Wk = Workbooks.Open(DocName)

On Error Resume Next
For Each Sh In Wk.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)).Delete
.Range(.Cells(DerLig + 1, 1), .Cells(.Rows.Count, .Columns.Count)).Delete
End If
End With
If Err <> 0 Then Err = 0
Next
Application.DisplayAlerts = False
With ShR
Compteur = Compteur + 1
.Range("A" & Compteur) = Wk.FullName
End With
Wk.Close True
Application.DisplayAlerts = True
Set Wk = Nothing
End Sub
'--------------------------------------------------------------------------------

Function ListeDossiers(dossier, Liste(), SousRep As Boolean)
Dim Fs As Object, F As Object
Dim F1 As Object, Sf As Object, A As Integer
Set Fs = CreateObject("Scripting.FileSystemObject")
Set F = Fs.GetFolder(dossier)

Set Sf = F.SubFolders
For Each F1 In Sf
ReDim Preserve Liste(0 To A)
Liste(A) = F1.Name
A = A + 1
Next
ListeDossiers = Liste
Erase Liste
End Function
'--------------------------------------------------------------------------------

Bonjour,

| 1) les xlsb ne sont pas lisibles avec des Excel antérieurs à 2007

Pack de compatibilité Microsoft Office pour les formats de fichier Word, Excel et PowerPoint
pour les versions Excel 2007 et Excel 2010. Pour ce qui est d'Excel 2013, comme cela fait plus
de 10 ans avec Excel 2013, il est possible que le "pack" ne soit plus compatible, je n'ai pas
testé explicitement cela.
Il est téléchargeable ici : http://www.microsoft.com/fr-fr/download/details.aspx?id=3

Attention : Cela permet d'ouvrir les fichiers en mode compatibilité, mais cela ne permet pas à
l'usager
d'utiliser les caractéristiques des versions plus récentes que sa propre version d'Office!

Désolé, je n'avais pas remarqué que tu étais l'auteur.
Daniel
Dans son message précédent, Jacquouille a écrit :

Hé Daniel
Tu étais à l'affut?

Excel 2007, c'est quoi, ça? le 4° millénaire? -))

Jacques 1948, XL2003
Jacquouille