Appliquer macro à tout les fichier Excel d'un repertoire

Le 14/08/2013 à 10:39

Bonjour,

Je travaille tous les mois sur des fichier excel que je dois mettre en forme et protéger de manière identique.

Pour cela j'utilise la macro suivante

Sub Variables()

'

' Variables Macro

'

' Touche de raccourci du clavier: Ctrl+l

'

Columns("A:I").Select

Columns("A:I").EntireColumn.AutoFit

Range("E3").Select

ActiveCell.FormulaR1C1 = "=IF(RC4="""","""",IF(R2C="""","""",0))"

Range("E3").Select

Selection.AutoFill Destination:=Range("E3:I3"), Type:=xlFillDefault

Range("E3:I3").Select

Selection.AutoFill Destination:=Range("E3:I200"), Type:=xlFillDefault

Range("E3:I200").Select

Selection.Copy

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=True, Transpose:=False

Application.CutCopyMode = False

With Selection.Validation

.Delete

.Add Type:=xlValidateDecimal, AlertStyle:=xlValidAlertStop, Operator _

:=xlBetween, Formula1:="0", Formula2:="9999"

.IgnoreBlank = True

.InCellDropdown = True

.InputTitle = ""

.ErrorTitle = ""

.InputMessage = ""

.ErrorMessage = ""

.ShowInput = True

.ShowError = True

End With

Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _

"=NBCAR(SUPPRESPACE(E3))=0"

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority

Selection.FormatConditions(1).Borders(xlLeft).LineStyle = xlNone

Selection.FormatConditions(1).Borders(xlRight).LineStyle = xlNone

Selection.FormatConditions(1).Borders(xlTop).LineStyle = xlNone

Selection.FormatConditions(1).Borders(xlBottom).LineStyle = xlNone

With Selection.FormatConditions(1).Interior

.Pattern = xlNone

.TintAndShade = 0

End With

Selection.FormatConditions(1).StopIfTrue = True

With ActiveSheet.PageSetup

.PrintTitleRows = "$1:$2"

.PrintTitleColumns = ""

End With

ActiveSheet.PageSetup.PrintArea = ""

With ActiveSheet.PageSetup

.LeftHeader = "&D"

.CenterHeader = "&F"

.RightHeader = ""

.LeftFooter = ""

.CenterFooter = ""

.RightFooter = ""

.LeftMargin = Application.InchesToPoints(0.78740157480315)

.RightMargin = Application.InchesToPoints(0.78740157480315)

.TopMargin = Application.InchesToPoints(0.984251968503937)

.BottomMargin = Application.InchesToPoints(0.984251968503937)

.HeaderMargin = Application.InchesToPoints(0.511811023622047)

.FooterMargin = Application.InchesToPoints(0.511811023622047)

.PrintHeadings = False

.PrintGridlines = False

.PrintComments = xlPrintNoComments

.CenterHorizontally = True

.CenterVertically = True

.Orientation = xlLandscape

.Draft = False

.PaperSize = xlPaperA4

.FirstPageNumber = xlAutomatic

.Order = xlDownThenOver

.BlackAndWhite = False

.Zoom = False

.FitToPagesWide = 1

.FitToPagesTall = 4

.PrintErrors = xlPrintErrorsDisplayed

.OddAndEvenPagesHeaderFooter = False

.DifferentFirstPageHeaderFooter = False

.ScaleWithDocHeaderFooter = True

.AlignMarginsHeaderFooter = False

.EvenPage.LeftHeader.Text = ""

.EvenPage.CenterHeader.Text = ""

.EvenPage.RightHeader.Text = ""

.EvenPage.LeftFooter.Text = ""

.EvenPage.CenterFooter.Text = ""

.EvenPage.RightFooter.Text = ""

.FirstPage.LeftHeader.Text = ""

.FirstPage.CenterHeader.Text = ""

.FirstPage.RightHeader.Text = ""

.FirstPage.LeftFooter.Text = ""

.FirstPage.CenterFooter.Text = ""

.FirstPage.RightFooter.Text = ""

End With

Columns("A:D").Select

Selection.Locked = True

Selection.FormulaHidden = False

Range("A:J").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True

lignefin = [A:J].Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row

ActiveSheet.PageSetup.PrintArea = Range("a1", Cells(lignefin, 9)).Address

Range("A:J").EntireRow.Hidden = False

ActiveSheet.Protect Password:="PAIE"

ActiveWorkbook.Save

ActiveWorkbook.Close

Application.Quit

End Sub

J'aimerai appliquer cette macro à tous les fichiers se trouvant dans le dossier suivant

Z:\Région IDF Val de Loire PACA BOURGOGNE\BOURGOGNE\grille com 08.13

J'ai regarder pas mal de forum mais n'y est pas trouver de commande qui s'applique à mon projet.

Pourriez vous m'aider?

Merci d'avance,

Laurent

Le 14/08/2013 à 10:45

Bonjour,

teste cette macro :

Sub parcourirFichiers()
    Dim chemin As String, Fichier As String
    Dim wb As Workbook
    Set wb = ThisWorkbook
    chemin = wb.Path + "\"
    Fichier = Dir(chemin & "*.xl*")    ' 1er fichier
    Do While (Len(Fichier) > 0)
        If Fichier <> ThisWorkbook.Name Then
            Workbooks.Open chemin & Fichier
            ' traitement
            Variables
            ActiveWorkbook.Close
        End If
        Fichier = Dir()    ' fichier suivant
    Loop
End Sub

Le fichier doit être dans le répertoire à traiter. Elle ouvre tous les fichiers du répertoire où elle se trouve et lance ta macro.

eric

Le 14/08/2013 à 11:07

Whaooo super merci

Par contre je suis vraiment pas très doué

pouvez vous m'indiquer comment l'intégré à ma macro?

Dois-je copier ce texte avant ou après? ou intercallé ma macro dans ce code?

dois-je modifier certaine information? du style remplacé chemin par "Z:\Région IDF Val de Loire PACA BOURGOGNE\BOURGOGNE\grille com 08.13" dans

Fichier = Dir(chemin & "*.xl*") ' 1er fichier

Merci d'avance

Le 14/08/2013 à 13:06

C'est une autre macro qui appelle la tienne, la coller au-dessus, séparément.

Copie le fichier xls dans le répertoire que tu dois traiter, ouvre-le et lance cette macro.

eric

Le 14/08/2013 à 13:52

j'ai donc ceci

Sub parcourirFichiers()

Dim chemin As String, Fichier As String

Dim wb As Workbook

Set wb = ThisWorkbook

chemin = wb.Path + "\"

Fichier = Dir(chemin & "*.xl*") ' 1er fichier

Do While (Len(Fichier) > 0)

If Fichier <> ThisWorkbook.Name Then

Workbooks.Open chemin & Fichier

' traitement

Variables

ActiveWorkbook.Close

End If

Fichier = Dir() ' fichier suivant

Loop

End Sub

Sub Variables()

'

' Variables Macro

'

' Touche de raccourci du clavier: Ctrl+l

'

Columns("A:I").Select

Columns("A:I").EntireColumn.AutoFit

Range("E3").Select

ActiveCell.FormulaR1C1 = "=IF(RC4="""","""",IF(R2C="""","""",0))"

Range("E3").Select

Selection.AutoFill Destination:=Range("E3:I3"), Type:=xlFillDefault

Range("E3:I3").Select

Selection.AutoFill Destination:=Range("E3:I200"), Type:=xlFillDefault

Range("E3:I200").Select

Selection.Copy

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=True, Transpose:=False

Application.CutCopyMode = False

With Selection.Validation

.Delete

.Add Type:=xlValidateDecimal, AlertStyle:=xlValidAlertStop, Operator _

:=xlBetween, Formula1:="0", Formula2:="9999"

.IgnoreBlank = True

.InCellDropdown = True

.InputTitle = ""

.ErrorTitle = ""

.InputMessage = ""

.ErrorMessage = ""

.ShowInput = True

.ShowError = True

End With

Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _

"=NBCAR(SUPPRESPACE(E3))=0"

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority

Selection.FormatConditions(1).Borders(xlLeft).LineStyle = xlNone

Selection.FormatConditions(1).Borders(xlRight).LineStyle = xlNone

Selection.FormatConditions(1).Borders(xlTop).LineStyle = xlNone

Selection.FormatConditions(1).Borders(xlBottom).LineStyle = xlNone

With Selection.FormatConditions(1).Interior

.Pattern = xlNone

.TintAndShade = 0

End With

Selection.FormatConditions(1).StopIfTrue = True

With ActiveSheet.PageSetup

.PrintTitleRows = "$1:$2"

.PrintTitleColumns = ""

End With

ActiveSheet.PageSetup.PrintArea = ""

With ActiveSheet.PageSetup

.LeftHeader = "&D"

.CenterHeader = "&F"

.RightHeader = ""

.LeftFooter = ""

.CenterFooter = ""

.RightFooter = ""

.LeftMargin = Application.InchesToPoints(0.78740157480315)

.RightMargin = Application.InchesToPoints(0.78740157480315)

.TopMargin = Application.InchesToPoints(0.984251968503937)

.BottomMargin = Application.InchesToPoints(0.984251968503937)

.HeaderMargin = Application.InchesToPoints(0.511811023622047)

.FooterMargin = Application.InchesToPoints(0.511811023622047)

.PrintHeadings = False

.PrintGridlines = False

.PrintComments = xlPrintNoComments

.CenterHorizontally = True

.CenterVertically = True

.Orientation = xlLandscape

.Draft = False

.PaperSize = xlPaperA4

.FirstPageNumber = xlAutomatic

.Order = xlDownThenOver

.BlackAndWhite = False

.Zoom = False

.FitToPagesWide = 1

.FitToPagesTall = 4

.PrintErrors = xlPrintErrorsDisplayed

.OddAndEvenPagesHeaderFooter = False

.DifferentFirstPageHeaderFooter = False

.ScaleWithDocHeaderFooter = True

.AlignMarginsHeaderFooter = False

.EvenPage.LeftHeader.Text = ""

.EvenPage.CenterHeader.Text = ""

.EvenPage.RightHeader.Text = ""

.EvenPage.LeftFooter.Text = ""

.EvenPage.CenterFooter.Text = ""

.EvenPage.RightFooter.Text = ""

.FirstPage.LeftHeader.Text = ""

.FirstPage.CenterHeader.Text = ""

.FirstPage.RightHeader.Text = ""

.FirstPage.LeftFooter.Text = ""

.FirstPage.CenterFooter.Text = ""

.FirstPage.RightFooter.Text = ""

End With

Columns("A:D").Select

Selection.Locked = True

Selection.FormulaHidden = False

Range("A:J").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True

lignefin = [A:J].Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row

ActiveSheet.PageSetup.PrintArea = Range("a1", Cells(lignefin, 9)).Address

Range("A:J").EntireRow.Hidden = False

ActiveSheet.Protect Password:="PAIE"

Range("A2").Select

ActiveWorkbook.Save

ActiveWorkbook.Close

End Sub

cela exécute normalement ma macro sur le fichier ouvert mais pas sur le reste du dossier.

Merci beaucoup pour votre aide

Le 14/08/2013 à 16:37

Il faut exécuter parcourirFichiers(), pas la tienne.

eric

Le 21/08/2013 à 15:21

je suis pas sur de saisir.

Mais merci de ton aide

Le 21/08/2013 à 16:06

Bonjour,

Je ne peux pas expliquer autrement.

C'est ce que tu as demandé. C'est une macro qui ouvre successivement tous les fichiers xls, xlsx, xlsm du répertoire où elle est, et qui lance ta macro qui s'appliquera donc sur la feuille active puisque tu n'y as pas spécifié de feuille.

Par contre je viens de voir que ta macro se termine avec un ActiveWorkbook.Close. Il faut l'enlever puisque c'est géré par ma macro.

eric

Rechercher des sujets similaires à "appliquer macro tout fichier repertoire"