Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel Grande Macro repete

Grande Macro repete

5 réponses
Avatar
Domy
Bonjour,

J'ai une grande macro, et j'ai besoin de la repete 26 fois.
Ce qui m'embete, c'est qu'il n'y a qu'une ligne que j'ai besoin de changer.
Voila la ligne a changer :

Selection.AutoFilter Field:=12, Criteria1:="1800"
Cette ligne doit changer en :
Selection.AutoFilter Field:=12, Criteria1:="7600"
ou
Selection.AutoFilter Field:=12, Criteria1:="5600"
et ainsi de suite selon la destination que je cherche.

Voila la macro original pour le 1800.
Si qqun peut me depanner, je l'en remercie d'avance.

Sub Bourges()
'Suppression de la Feuille Prioritaire
Sheets("Prioritaire").Select
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Sheets("Feuil2").Select
Sheets.Add
'Creation de la Feuille Prioritaire
[A1] = "Prioritaire"
Dim Name As String
Name = Range("A1")
Application.ScreenUpdating = False
ActiveSheet.Name = (Name)
[A1].Clear


Sheets("Prioritaire").Select
Sheets("Feuil2").Select
Selection.AutoFilter Field:=12, Criteria1:="1800"
Rows("1:3000").Select
Selection.Copy
Sheets("Prioritaire").Select
[5:5].Select
ActiveSheet.Paste
[A:A].Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlToRight
[A:AB].Select
[A:AB].EntireColumn.AutoFit

[C:E].Select
Selection.Delete Shift:=xlToLeft
[E:E,G:G,H:H].Select
Selection.Delete Shift:=xlToLeft
[M:W].Select
Selection.Delete Shift:=xlToLeft
[A1].Select

[B6:P300].Select
Selection.Sort Key1:=Range("B6"), Order1:=xlAscending, Key2:=Range("F6")
_
, Order2:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:=
_
False, Orientation:=xlTopToBottom


[B1] = [H6].Value
[M5:P5] = [I5:L5].Value
[M5:P5].EntireColumn.AutoFit
'Ecriture du Congelé
Sheets("Ecrit").Select
[M3:P3].Select
Selection.Copy
Sheets("Prioritaire").Select
[M7:P300].Select
ActiveSheet.Paste
[M6:P300] = [M6:P300].Value
'Suppression des lignes SU
For lin = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Row
To 1 Step -1
If Cells(lin, 6) = "SU" Then Rows(lin).Delete Shift:=xlUp
Next lin

'Mise en place du temps de Trajet
[F6].Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-3],Ecrit!R1C4:R26C5,2,FALSE)"
[F7].Select
[F6].Select
Selection.Copy
[F6:F300].Select
ActiveSheet.Paste
[F6:F300] = [F6:F300].Value
[F6:F300].Select
Selection.NumberFormat = "h:mm"
' Calcule de l'heure prevue d'arrivée
[G6].Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-2]+RC[-1])"
[G7].Select
[G6].Select
Selection.Copy
[G6:G300].Select
ActiveSheet.Paste
[G6:G300].Select
[G6:G300] = [G6:G300].Value
Selection.NumberFormat = "h:mm"
' Suppression des temps de trajet et heures departs
[E:F].Select
Selection.Delete Shift:=xlToLeft
'Inscription de l'agence expeditrice
[D6].Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],Ecrit!R1C4:R26C6,3,FALSE)"
[D7].Select
[D6].Select
Selection.Copy
[D6:D300].Select
ActiveSheet.Paste
[C6:C300] = [D6:D300].Value
'Recherche de la l'agence destinatrice
[A6].Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[1],6)"
[A7].Select
[A6].Select
Selection.Copy
[A6:A300].Select
ActiveSheet.Paste
[A6:A300] = [A6:A300].Value
'Recherche de la l'agence destinatrice 2
[D6].Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[-3],2)"
[D7].Select
[D6].Select
Selection.Copy
[D6:D300].Select
ActiveSheet.Paste
[D6:D300] = [D6:D300].Value
[A:A].Clear
' Ecriture de l'agence destinatrice
[E:E].Select
Selection.Insert Shift:=xlToRight
[E6].Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],Ecrit!R1C4:R27C6,3,FALSE)"
[E7].Select
[E6].Select
Selection.Copy
[E6:E300].Select
ActiveSheet.Paste
[E6:E300] = [E6:E300].Value
[D:D].Select
Selection.Delete Shift:=xlToLeft
' Ecriture des Intitulés en gras
[B5] = "Codification Navette"
[C5] = "Agence Départ"
[D5] = "Agence Destinatrice"
[E5] = "Heure Prévue"
[B4:N5].Select
Selection.Font.Bold = True
[5:5].Select
Selection.RowHeight = 20


[F:F].Select
Selection.Delete Shift:=xlToLeft
[B:N].EntireColumn.AutoFit
' Hauteur Ligne + Ecriture Frais & Congelé
[4:4].Select
Selection.RowHeight = 25
[F4:I4].Select
Selection.Merge
[F4:I4] = "Frais"
[J4:M4].Select
Selection.Merge
[J4:M4] = "Surgelé"
Cells.Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
[B4] = "domy"
[B6:M300].Borders.Weight = xlThin

' Effacement des ligne ou la colonne B est vide
derniereLigne = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For r = derniereLigne To 1 Step -1
If IsEmpty(Range("B" & r)) Then Rows(r).Clear
Next r
[B4].Clear
'Mettre des Bordures
[F4:I4].Borders.Weight = xlMedium
[J4:M4].Borders.Weight = xlMedium
[B5:M5].Borders.Weight = xlMedium
' Deplacement de l'agence
[B4] = [B1].Value
[B4:E4].Select
Selection.Merge
[B4:E4].Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With Selection.Font
.Name = "Arial"
.Size = 18
.Bold = True
End With
[1:2].Select
Selection.Delete Shift:=xlToLeft
ActiveWindow.DisplayZeros = False
' Inscription de la date
Sheets("Prioritaire").[B1].Value = Sheets("Feuil2").[D2].Value

[A1].Select


' Preparer a imprimer
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = -2
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
End With



'Importation Ramasses
Workbooks("Importation
Elit.xls").Sheets("Prioritaire").[B305:B357].Value =
Workbooks("Transit.xls").Sheets("Ramasses").[A5:A57].Value
Workbooks("Importation
Elit.xls").Sheets("Prioritaire").[F305:J357].Value =
Workbooks("Transit.xls").Sheets("Ramasses").[N5:R57].Value
Windows("Importation Elit.xls").Activate
Sheets("Prioritaire").Select
[B304] = "Expéditeur"
[F304] = "Eur"
[G304] = "Roll"
[H304] = "Pr"
[I304] = "Eur"
[J304] = "Roll"
[F303:H303].Select
Selection.Merge
[F303:H303] = "Frais"
[I303:J303].Select
Selection.Merge
[I303:J303] = "Surgelé"
[303:303].Select
Selection.RowHeight = 25
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
[F303:J303].Borders.Weight = xlMedium
[B304:J304].Borders.Weight = xlMedium

[B303:E303].Select
Selection.Merge
[B303:E303] = "Ramasses"

[B303:J303].Select
With Selection.Font
.Name = "Arial"
.Bold = True
End With
[B303:E303].Font.Size = 18


[B305:J358].Borders.Weight = xlThin

[C305:C357].FormulaR1C1 = "=SUM(RC[3]:RC[9])"
[A305:A357].FormulaR1C1 = "=IF(RC[2]>=1,RC[1],"""")"
[B305:B357] = [A305:A357].Value
[B305:B357].HorizontalAlignment = xlLeft

' Effacement des ligne ou la colonne B est vide
[A:A].Clear
[C305:C357] = Clear
[B358] = "Total"
With Selection.Font
.Name = "Arial"
.Bold = True
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With Range("B1", Range("B360").End(xlUp)). _
SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With

Range("A1").Select



ActiveWindow.SelectedSheets.PrintOut Copies:=1


End Sub
J'ai peur que si je copie 26 fois cette macro cela alourdit enormement mon
fichier.
Merci de votre aide
Signaler un problème avec ce contenu

5 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
Avatar
isabelle
bonjour Domy,

une solution serait de faire une boucle,

Dim Criteria1, myval
Criteria1 = Array("1800", "7600", "5600")
For i = 0 To 2
myval = Criteria1(i)
'le reste de la macro avec
' Selection.AutoFilter Field:, Criteria1:=myval
Next

isabelle



Bonjour,

J'ai une grande macro, et j'ai besoin de la repete 26 fois.
Ce qui m'embete, c'est qu'il n'y a qu'une ligne que j'ai besoin de changer.
Voila la ligne a changer :

Selection.AutoFilter Field:, Criteria1:="1800"
Cette ligne doit changer en :
Selection.AutoFilter Field:, Criteria1:="7600"
ou
Selection.AutoFilter Field:, Criteria1:="5600"
et ainsi de suite selon la destination que je cherche.

Voila la macro original pour le 1800.
Si qqun peut me depanner, je l'en remercie d'avance.

Sub Bourges()
'Suppression de la Feuille Prioritaire
Sheets("Prioritaire").Select
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Sheets("Feuil2").Select
Sheets.Add
'Creation de la Feuille Prioritaire
[A1] = "Prioritaire"
Dim Name As String
Name = Range("A1")
Application.ScreenUpdating = False
ActiveSheet.Name = (Name)
[A1].Clear

Sheets("Prioritaire").Select
Sheets("Feuil2").Select
Selection.AutoFilter Field:, Criteria1:="1800"
Rows("1:3000").Select
Selection.Copy
Sheets("Prioritaire").Select
[5:5].Select
ActiveSheet.Paste
[A:A].Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlToRight
[A:AB].Select
[A:AB].EntireColumn.AutoFit

[C:E].Select
Selection.Delete Shift:=xlToLeft
[E:E,G:G,H:H].Select
Selection.Delete Shift:=xlToLeft
[M:W].Select
Selection.Delete Shift:=xlToLeft
[A1].Select

[B6:P300].Select
Selection.Sort Key1:=Range("B6"), Order1:=xlAscending, Key2:=Range("F6")
_
, Order2:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase: > _
False, Orientation:=xlTopToBottom

[B1] = [H6].Value
[M5:P5] = [I5:L5].Value
[M5:P5].EntireColumn.AutoFit
'Ecriture du Congelé
Sheets("Ecrit").Select
[M3:P3].Select
Selection.Copy
Sheets("Prioritaire").Select
[M7:P300].Select
ActiveSheet.Paste
[M6:P300] = [M6:P300].Value
'Suppression des lignes SU
For lin = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Row
To 1 Step -1
If Cells(lin, 6) = "SU" Then Rows(lin).Delete Shift:=xlUp
Next lin

'Mise en place du temps de Trajet
[F6].Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-3],Ecrit!R1C4:R26C5,2,FALSE)"
[F7].Select
[F6].Select
Selection.Copy
[F6:F300].Select
ActiveSheet.Paste
[F6:F300] = [F6:F300].Value
[F6:F300].Select
Selection.NumberFormat = "h:mm"
' Calcule de l'heure prevue d'arrivée
[G6].Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-2]+RC[-1])"
[G7].Select
[G6].Select
Selection.Copy
[G6:G300].Select
ActiveSheet.Paste
[G6:G300].Select
[G6:G300] = [G6:G300].Value
Selection.NumberFormat = "h:mm"
' Suppression des temps de trajet et heures departs
[E:F].Select
Selection.Delete Shift:=xlToLeft
'Inscription de l'agence expeditrice
[D6].Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],Ecrit!R1C4:R26C6,3,FALSE)"
[D7].Select
[D6].Select
Selection.Copy
[D6:D300].Select
ActiveSheet.Paste
[C6:C300] = [D6:D300].Value
'Recherche de la l'agence destinatrice
[A6].Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[1],6)"
[A7].Select
[A6].Select
Selection.Copy
[A6:A300].Select
ActiveSheet.Paste
[A6:A300] = [A6:A300].Value
'Recherche de la l'agence destinatrice 2
[D6].Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[-3],2)"
[D7].Select
[D6].Select
Selection.Copy
[D6:D300].Select
ActiveSheet.Paste
[D6:D300] = [D6:D300].Value
[A:A].Clear
' Ecriture de l'agence destinatrice
[E:E].Select
Selection.Insert Shift:=xlToRight
[E6].Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],Ecrit!R1C4:R27C6,3,FALSE)"
[E7].Select
[E6].Select
Selection.Copy
[E6:E300].Select
ActiveSheet.Paste
[E6:E300] = [E6:E300].Value
[D:D].Select
Selection.Delete Shift:=xlToLeft
' Ecriture des Intitulés en gras
[B5] = "Codification Navette"
[C5] = "Agence Départ"
[D5] = "Agence Destinatrice"
[E5] = "Heure Prévue"
[B4:N5].Select
Selection.Font.Bold = True
[5:5].Select
Selection.RowHeight = 20

[F:F].Select
Selection.Delete Shift:=xlToLeft
[B:N].EntireColumn.AutoFit
' Hauteur Ligne + Ecriture Frais & Congelé
[4:4].Select
Selection.RowHeight = 25
[F4:I4].Select
Selection.Merge
[F4:I4] = "Frais"
[J4:M4].Select
Selection.Merge
[J4:M4] = "Surgelé"
Cells.Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
[B4] = "domy"
[B6:M300].Borders.Weight = xlThin

' Effacement des ligne ou la colonne B est vide
derniereLigne = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For r = derniereLigne To 1 Step -1
If IsEmpty(Range("B" & r)) Then Rows(r).Clear
Next r
[B4].Clear
'Mettre des Bordures
[F4:I4].Borders.Weight = xlMedium
[J4:M4].Borders.Weight = xlMedium
[B5:M5].Borders.Weight = xlMedium
' Deplacement de l'agence
[B4] = [B1].Value
[B4:E4].Select
Selection.Merge
[B4:E4].Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With Selection.Font
.Name = "Arial"
.Size = 18
.Bold = True
End With
[1:2].Select
Selection.Delete Shift:=xlToLeft
ActiveWindow.DisplayZeros = False
' Inscription de la date
Sheets("Prioritaire").[B1].Value = Sheets("Feuil2").[D2].Value

[A1].Select

' Preparer a imprimer
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = -2
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
End With

'Importation Ramasses
Workbooks("Importation
Elit.xls").Sheets("Prioritaire").[B305:B357].Value > Workbooks("Transit.xls").Sheets("Ramasses").[A5:A57].Value
Workbooks("Importation
Elit.xls").Sheets("Prioritaire").[F305:J357].Value > Workbooks("Transit.xls").Sheets("Ramasses").[N5:R57].Value
Windows("Importation Elit.xls").Activate
Sheets("Prioritaire").Select
[B304] = "Expéditeur"
[F304] = "Eur"
[G304] = "Roll"
[H304] = "Pr"
[I304] = "Eur"
[J304] = "Roll"
[F303:H303].Select
Selection.Merge
[F303:H303] = "Frais"
[I303:J303].Select
Selection.Merge
[I303:J303] = "Surgelé"
[303:303].Select
Selection.RowHeight = 25
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
[F303:J303].Borders.Weight = xlMedium
[B304:J304].Borders.Weight = xlMedium

[B303:E303].Select
Selection.Merge
[B303:E303] = "Ramasses"

[B303:J303].Select
With Selection.Font
.Name = "Arial"
.Bold = True
End With
[B303:E303].Font.Size = 18

[B305:J358].Borders.Weight = xlThin

[C305:C357].FormulaR1C1 = "=SUM(RC[3]:RC[9])"
[A305:A357].FormulaR1C1 = "=IF(RC[2]>=1,RC[1],"""")"
[B305:B357] = [A305:A357].Value
[B305:B357].HorizontalAlignment = xlLeft

' Effacement des ligne ou la colonne B est vide
[A:A].Clear
[C305:C357] = Clear
[B358] = "Total"
With Selection.Font
.Name = "Arial"
.Bold = True
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With Range("B1", Range("B360").End(xlUp)). _
SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With

Range("A1").Select

ActiveWindow.SelectedSheets.PrintOut Copies:=1

End Sub
J'ai peur que si je copie 26 fois cette macro cela alourdit enormement mon
fichier.
Merci de votre aide


Avatar
Paul V.
Salut Domy,

J'ai eu la flemme d'entrer dans le détail de ta macro.
Mais tu pourrais insérer une sous routine ou meme insérer directement dans
ton code un select case

A un endroit ou le code doit se répéter mais après les déclarations s'il y
en a, tu insères

repetition:

Pas oublier le ":"

A la place de ton instruction :

select case Cr
case 1
crit= 1800
case 2
crit = 7600
.... etc
end select
Selection.AutoFilter Field:, Criteria1:=crit

A la fin de ta macro

Goto repetition

C'est tapé vite fait sans test. Si t'en sors pas; reviens

A+

Paul V





Domy wrote:
Bonjour,

J'ai une grande macro, et j'ai besoin de la repete 26 fois.
Ce qui m'embete, c'est qu'il n'y a qu'une ligne que j'ai besoin de
changer. Voila la ligne a changer :

Selection.AutoFilter Field:, Criteria1:="1800"
Cette ligne doit changer en :
Selection.AutoFilter Field:, Criteria1:="7600"
ou
Selection.AutoFilter Field:, Criteria1:="5600"
et ainsi de suite selon la destination que je cherche.

Voila la macro original pour le 1800.
Si qqun peut me depanner, je l'en remercie d'avance.

Sub Bourges()
'Suppression de la Feuille Prioritaire
Sheets("Prioritaire").Select
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Sheets("Feuil2").Select
Sheets.Add
'Creation de la Feuille Prioritaire
[A1] = "Prioritaire"
Dim Name As String
Name = Range("A1")
Application.ScreenUpdating = False
ActiveSheet.Name = (Name)
[A1].Clear


Sheets("Prioritaire").Select
Sheets("Feuil2").Select
Selection.AutoFilter Field:, Criteria1:="1800"
Rows("1:3000").Select
Selection.Copy
Sheets("Prioritaire").Select
[5:5].Select
ActiveSheet.Paste
[A:A].Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlToRight
[A:AB].Select
[A:AB].EntireColumn.AutoFit

[C:E].Select
Selection.Delete Shift:=xlToLeft
[E:E,G:G,H:H].Select
Selection.Delete Shift:=xlToLeft
[M:W].Select
Selection.Delete Shift:=xlToLeft
[A1].Select

[B6:P300].Select
Selection.Sort Key1:=Range("B6"), Order1:=xlAscending,
Key2:=Range("F6") _
, Order2:=xlDescending, Header:=xlGuess, OrderCustom:=1,
MatchCase:= _
False, Orientation:=xlTopToBottom


[B1] = [H6].Value
[M5:P5] = [I5:L5].Value
[M5:P5].EntireColumn.AutoFit
'Ecriture du Congelé
Sheets("Ecrit").Select
[M3:P3].Select
Selection.Copy
Sheets("Prioritaire").Select
[M7:P300].Select
ActiveSheet.Paste
[M6:P300] = [M6:P300].Value
'Suppression des lignes SU
For lin = ActiveSheet.UsedRange.Rows.Count +
ActiveSheet.UsedRange.Row To 1 Step -1
If Cells(lin, 6) = "SU" Then Rows(lin).Delete Shift:=xlUp
Next lin

'Mise en place du temps de Trajet
[F6].Select
ActiveCell.FormulaR1C1 > "=VLOOKUP(RC[-3],Ecrit!R1C4:R26C5,2,FALSE)" [F7].Select
[F6].Select
Selection.Copy
[F6:F300].Select
ActiveSheet.Paste
[F6:F300] = [F6:F300].Value
[F6:F300].Select
Selection.NumberFormat = "h:mm"
' Calcule de l'heure prevue d'arrivée
[G6].Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-2]+RC[-1])"
[G7].Select
[G6].Select
Selection.Copy
[G6:G300].Select
ActiveSheet.Paste
[G6:G300].Select
[G6:G300] = [G6:G300].Value
Selection.NumberFormat = "h:mm"
' Suppression des temps de trajet et heures departs
[E:F].Select
Selection.Delete Shift:=xlToLeft
'Inscription de l'agence expeditrice
[D6].Select
ActiveCell.FormulaR1C1 > "=VLOOKUP(RC[-1],Ecrit!R1C4:R26C6,3,FALSE)" [D7].Select
[D6].Select
Selection.Copy
[D6:D300].Select
ActiveSheet.Paste
[C6:C300] = [D6:D300].Value
'Recherche de la l'agence destinatrice
[A6].Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[1],6)"
[A7].Select
[A6].Select
Selection.Copy
[A6:A300].Select
ActiveSheet.Paste
[A6:A300] = [A6:A300].Value
'Recherche de la l'agence destinatrice 2
[D6].Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[-3],2)"
[D7].Select
[D6].Select
Selection.Copy
[D6:D300].Select
ActiveSheet.Paste
[D6:D300] = [D6:D300].Value
[A:A].Clear
' Ecriture de l'agence destinatrice
[E:E].Select
Selection.Insert Shift:=xlToRight
[E6].Select
ActiveCell.FormulaR1C1 > "=VLOOKUP(RC[-1],Ecrit!R1C4:R27C6,3,FALSE)" [E7].Select
[E6].Select
Selection.Copy
[E6:E300].Select
ActiveSheet.Paste
[E6:E300] = [E6:E300].Value
[D:D].Select
Selection.Delete Shift:=xlToLeft
' Ecriture des Intitulés en gras
[B5] = "Codification Navette"
[C5] = "Agence Départ"
[D5] = "Agence Destinatrice"
[E5] = "Heure Prévue"
[B4:N5].Select
Selection.Font.Bold = True
[5:5].Select
Selection.RowHeight = 20


[F:F].Select
Selection.Delete Shift:=xlToLeft
[B:N].EntireColumn.AutoFit
' Hauteur Ligne + Ecriture Frais & Congelé
[4:4].Select
Selection.RowHeight = 25
[F4:I4].Select
Selection.Merge
[F4:I4] = "Frais"
[J4:M4].Select
Selection.Merge
[J4:M4] = "Surgelé"
Cells.Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
[B4] = "domy"
[B6:M300].Borders.Weight = xlThin

' Effacement des ligne ou la colonne B est vide
derniereLigne = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For r = derniereLigne To 1 Step -1
If IsEmpty(Range("B" & r)) Then Rows(r).Clear
Next r
[B4].Clear
'Mettre des Bordures
[F4:I4].Borders.Weight = xlMedium
[J4:M4].Borders.Weight = xlMedium
[B5:M5].Borders.Weight = xlMedium
' Deplacement de l'agence
[B4] = [B1].Value
[B4:E4].Select
Selection.Merge
[B4:E4].Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With Selection.Font
.Name = "Arial"
.Size = 18
.Bold = True
End With
[1:2].Select
Selection.Delete Shift:=xlToLeft
ActiveWindow.DisplayZeros = False
' Inscription de la date
Sheets("Prioritaire").[B1].Value = Sheets("Feuil2").[D2].Value

[A1].Select


' Preparer a imprimer
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = -2
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
End With



'Importation Ramasses
Workbooks("Importation
Elit.xls").Sheets("Prioritaire").[B305:B357].Value > Workbooks("Transit.xls").Sheets("Ramasses").[A5:A57].Value
Workbooks("Importation
Elit.xls").Sheets("Prioritaire").[F305:J357].Value > Workbooks("Transit.xls").Sheets("Ramasses").[N5:R57].Value
Windows("Importation Elit.xls").Activate
Sheets("Prioritaire").Select
[B304] = "Expéditeur"
[F304] = "Eur"
[G304] = "Roll"
[H304] = "Pr"
[I304] = "Eur"
[J304] = "Roll"
[F303:H303].Select
Selection.Merge
[F303:H303] = "Frais"
[I303:J303].Select
Selection.Merge
[I303:J303] = "Surgelé"
[303:303].Select
Selection.RowHeight = 25
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
[F303:J303].Borders.Weight = xlMedium
[B304:J304].Borders.Weight = xlMedium

[B303:E303].Select
Selection.Merge
[B303:E303] = "Ramasses"

[B303:J303].Select
With Selection.Font
.Name = "Arial"
.Bold = True
End With
[B303:E303].Font.Size = 18


[B305:J358].Borders.Weight = xlThin

[C305:C357].FormulaR1C1 = "=SUM(RC[3]:RC[9])"
[A305:A357].FormulaR1C1 = "=IF(RC[2]>=1,RC[1],"""")"
[B305:B357] = [A305:A357].Value
[B305:B357].HorizontalAlignment = xlLeft

' Effacement des ligne ou la colonne B est vide
[A:A].Clear
[C305:C357] = Clear
[B358] = "Total"
With Selection.Font
.Name = "Arial"
.Bold = True
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With Range("B1", Range("B360").End(xlUp)). _
SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With

Range("A1").Select



ActiveWindow.SelectedSheets.PrintOut Copies:=1


End Sub
J'ai peur que si je copie 26 fois cette macro cela alourdit
enormement mon fichier.
Merci de votre aide


Avatar
Domy
Oui je peux, mais le probleme est que je n'ai pas besoin de sortir toute les
destination d'un seul coup.
Car j'ai des infos qui arrive en permanence, donc si je pouvais sortir que
celle qu'on me demande cela m'arrangerais.

"François" a écrit dans le message de
news:08a801c37df4$459523c0$
Bonjour,

Vous pouvez soit faire un copier coller et modifier
manuellement la ligne et le non de la macro
soit remplacer 1800 par une variable celle ci étant saisie
par l'utilisateur avec une MSGBOX ou bien correpondant à
une cellule donnée de votre feuille ou encore à l'aide
d'une liste déroulante dans votre feuille reprenant les 26
valeurs et donnant la valeur du filtre dans une cellule
liée

Bonne soirée

François



-----Message d'origine-----
Bonjour,

J'ai une grande macro, et j'ai besoin de la repete 26
fois.

Ce qui m'embete, c'est qu'il n'y a qu'une ligne que j'ai
besoin de changer.

Voila la ligne a changer :

Selection.AutoFilter Field:, Criteria1:="1800"
Cette ligne doit changer en :
Selection.AutoFilter Field:, Criteria1:="7600"
ou
Selection.AutoFilter Field:, Criteria1:="5600"
et ainsi de suite selon la destination que je cherche.

Voila la macro original pour le 1800.
Si qqun peut me depanner, je l'en remercie d'avance.

Sub Bourges()
'Suppression de la Feuille Prioritaire
Sheets("Prioritaire").Select
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Sheets("Feuil2").Select
Sheets.Add
'Creation de la Feuille Prioritaire
[A1] = "Prioritaire"
Dim Name As String
Name = Range("A1")
Application.ScreenUpdating = False
ActiveSheet.Name = (Name)
[A1].Clear


Sheets("Prioritaire").Select
Sheets("Feuil2").Select
Selection.AutoFilter Field:, Criteria1:="1800"
Rows("1:3000").Select
Selection.Copy
Sheets("Prioritaire").Select
[5:5].Select
ActiveSheet.Paste
[A:A].Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlToRight
[A:AB].Select
[A:AB].EntireColumn.AutoFit

[C:E].Select
Selection.Delete Shift:=xlToLeft
[E:E,G:G,H:H].Select
Selection.Delete Shift:=xlToLeft
[M:W].Select
Selection.Delete Shift:=xlToLeft
[A1].Select

[B6:P300].Select
Selection.Sort Key1:=Range("B6"),
Order1:=xlAscending, Key2:=Range("F6")

_
, Order2:=xlDescending, Header:=xlGuess,
OrderCustom:=1, MatchCase: >_

False, Orientation:=xlTopToBottom


[B1] = [H6].Value
[M5:P5] = [I5:L5].Value
[M5:P5].EntireColumn.AutoFit
'Ecriture du Congelé
Sheets("Ecrit").Select
[M3:P3].Select
Selection.Copy
Sheets("Prioritaire").Select
[M7:P300].Select
ActiveSheet.Paste
[M6:P300] = [M6:P300].Value
'Suppression des lignes SU
For lin = ActiveSheet.UsedRange.Rows.Count +
ActiveSheet.UsedRange.Row

To 1 Step -1
If Cells(lin, 6) = "SU" Then Rows(lin).Delete
Shift:=xlUp

Next lin

'Mise en place du temps de Trajet
[F6].Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-3],Ecrit!
R1C4:R26C5,2,FALSE)"

[F7].Select
[F6].Select
Selection.Copy
[F6:F300].Select
ActiveSheet.Paste
[F6:F300] = [F6:F300].Value
[F6:F300].Select
Selection.NumberFormat = "h:mm"
' Calcule de l'heure prevue d'arrivée
[G6].Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-2]+RC[-1])"
[G7].Select
[G6].Select
Selection.Copy
[G6:G300].Select
ActiveSheet.Paste
[G6:G300].Select
[G6:G300] = [G6:G300].Value
Selection.NumberFormat = "h:mm"
' Suppression des temps de trajet et heures departs
[E:F].Select
Selection.Delete Shift:=xlToLeft
'Inscription de l'agence expeditrice
[D6].Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],Ecrit!
R1C4:R26C6,3,FALSE)"

[D7].Select
[D6].Select
Selection.Copy
[D6:D300].Select
ActiveSheet.Paste
[C6:C300] = [D6:D300].Value
'Recherche de la l'agence destinatrice
[A6].Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[1],6)"
[A7].Select
[A6].Select
Selection.Copy
[A6:A300].Select
ActiveSheet.Paste
[A6:A300] = [A6:A300].Value
'Recherche de la l'agence destinatrice 2
[D6].Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[-3],2)"
[D7].Select
[D6].Select
Selection.Copy
[D6:D300].Select
ActiveSheet.Paste
[D6:D300] = [D6:D300].Value
[A:A].Clear
' Ecriture de l'agence destinatrice
[E:E].Select
Selection.Insert Shift:=xlToRight
[E6].Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],Ecrit!
R1C4:R27C6,3,FALSE)"

[E7].Select
[E6].Select
Selection.Copy
[E6:E300].Select
ActiveSheet.Paste
[E6:E300] = [E6:E300].Value
[D:D].Select
Selection.Delete Shift:=xlToLeft
' Ecriture des Intitulés en gras
[B5] = "Codification Navette"
[C5] = "Agence Départ"
[D5] = "Agence Destinatrice"
[E5] = "Heure Prévue"
[B4:N5].Select
Selection.Font.Bold = True
[5:5].Select
Selection.RowHeight = 20


[F:F].Select
Selection.Delete Shift:=xlToLeft
[B:N].EntireColumn.AutoFit
' Hauteur Ligne + Ecriture Frais & Congelé
[4:4].Select
Selection.RowHeight = 25
[F4:I4].Select
Selection.Merge
[F4:I4] = "Frais"
[J4:M4].Select
Selection.Merge
[J4:M4] = "Surgelé"
Cells.Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
[B4] = "domy"
[B6:M300].Borders.Weight = xlThin

' Effacement des ligne ou la colonne B est vide
derniereLigne = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For r = derniereLigne To 1 Step -1
If IsEmpty(Range("B" & r)) Then Rows(r).Clear
Next r
[B4].Clear
'Mettre des Bordures
[F4:I4].Borders.Weight = xlMedium
[J4:M4].Borders.Weight = xlMedium
[B5:M5].Borders.Weight = xlMedium
' Deplacement de l'agence
[B4] = [B1].Value
[B4:E4].Select
Selection.Merge
[B4:E4].Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With Selection.Font
.Name = "Arial"
.Size = 18
.Bold = True
End With
[1:2].Select
Selection.Delete Shift:=xlToLeft
ActiveWindow.DisplayZeros = False
' Inscription de la date
Sheets("Prioritaire").[B1].Value = Sheets("Feuil2").
[D2].Value


[A1].Select


' Preparer a imprimer
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = -2
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
End With



'Importation Ramasses
Workbooks("Importation
Elit.xls").Sheets("Prioritaire").[B305:B357].Value >Workbooks("Transit.xls").Sheets("Ramasses").[A5:A57].Value
Workbooks("Importation
Elit.xls").Sheets("Prioritaire").[F305:J357].Value >Workbooks("Transit.xls").Sheets("Ramasses").[N5:R57].Value
Windows("Importation Elit.xls").Activate
Sheets("Prioritaire").Select
[B304] = "Expéditeur"
[F304] = "Eur"
[G304] = "Roll"
[H304] = "Pr"
[I304] = "Eur"
[J304] = "Roll"
[F303:H303].Select
Selection.Merge
[F303:H303] = "Frais"
[I303:J303].Select
Selection.Merge
[I303:J303] = "Surgelé"
[303:303].Select
Selection.RowHeight = 25
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
[F303:J303].Borders.Weight = xlMedium
[B304:J304].Borders.Weight = xlMedium

[B303:E303].Select
Selection.Merge
[B303:E303] = "Ramasses"

[B303:J303].Select
With Selection.Font
.Name = "Arial"
.Bold = True
End With
[B303:E303].Font.Size = 18


[B305:J358].Borders.Weight = xlThin

[C305:C357].FormulaR1C1 = "=SUM(RC[3]:RC[9])"
[A305:A357].FormulaR1C1 = "=IF(RC[2]>=1,RC[1],"""")"
[B305:B357] = [A305:A357].Value
[B305:B357].HorizontalAlignment = xlLeft

' Effacement des ligne ou la colonne B est vide
[A:A].Clear
[C305:C357] = Clear
[B358] = "Total"
With Selection.Font
.Name = "Arial"
.Bold = True
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With Range("B1", Range("B360").End(xlUp)). _
SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With

Range("A1").Select



ActiveWindow.SelectedSheets.PrintOut Copies:=1


End Sub
J'ai peur que si je copie 26 fois cette macro cela
alourdit enormement mon

fichier.
Merci de votre aide


.



Avatar
Philippe.R
Bonsoir Domy,
Une des pistes proposées par François correspond plutôt bien me semble t il à ce scénario :

soit remplacer 1800 par une variable celle ci étant [...] choisie dans
une cellule donnée de votre feuille à l'aide
d'une liste déroulante dans votre feuille reprenant les 26
valeurs et donnant la valeur du filtre dans une cellule
liée
dans ce cas, le code pourrait être adapté ainsi en utilisant la référence de la cellule contenant

choix, Z1 par exemple :

Criteria1 = [z1]

--
Amicales Salutations

Retirer A_S_ pour répondre.
XL97 / XL2002
Pour suivre le forum :
news://msnews.microsoft.com/microsoft.public.fr.excel
(Voulez-vous vous abonner ? -> Oui)

"Domy" a écrit dans le message de news:
Oui je peux, mais le probleme est que je n'ai pas besoin de sortir toute les
destination d'un seul coup.
Car j'ai des infos qui arrive en permanence, donc si je pouvais sortir que
celle qu'on me demande cela m'arrangerais.

"François" a écrit dans le message de
news:08a801c37df4$459523c0$
Bonjour,

Vous pouvez soit faire un copier coller et modifier
manuellement la ligne et le non de la macro
soit remplacer 1800 par une variable celle ci étant saisie
par l'utilisateur avec une MSGBOX ou bien correpondant à
une cellule donnée de votre feuille ou encore à l'aide
d'une liste déroulante dans votre feuille reprenant les 26
valeurs et donnant la valeur du filtre dans une cellule
liée

Bonne soirée

François



-----Message d'origine-----
Bonjour,

J'ai une grande macro, et j'ai besoin de la repete 26
fois.

Ce qui m'embete, c'est qu'il n'y a qu'une ligne que j'ai
besoin de changer.

Voila la ligne a changer :

Selection.AutoFilter Field:, Criteria1:="1800"
Cette ligne doit changer en :
Selection.AutoFilter Field:, Criteria1:="7600"
ou
Selection.AutoFilter Field:, Criteria1:="5600"
et ainsi de suite selon la destination que je cherche.

Voila la macro original pour le 1800.
Si qqun peut me depanner, je l'en remercie d'avance.

Sub Bourges()
'Suppression de la Feuille Prioritaire
Sheets("Prioritaire").Select
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Sheets("Feuil2").Select
Sheets.Add
'Creation de la Feuille Prioritaire
[A1] = "Prioritaire"
Dim Name As String
Name = Range("A1")
Application.ScreenUpdating = False
ActiveSheet.Name = (Name)
[A1].Clear


Sheets("Prioritaire").Select
Sheets("Feuil2").Select
Selection.AutoFilter Field:, Criteria1:="1800"
Rows("1:3000").Select
Selection.Copy
Sheets("Prioritaire").Select
[5:5].Select
ActiveSheet.Paste
[A:A].Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlToRight
[A:AB].Select
[A:AB].EntireColumn.AutoFit

[C:E].Select
Selection.Delete Shift:=xlToLeft
[E:E,G:G,H:H].Select
Selection.Delete Shift:=xlToLeft
[M:W].Select
Selection.Delete Shift:=xlToLeft
[A1].Select

[B6:P300].Select
Selection.Sort Key1:=Range("B6"),
Order1:=xlAscending, Key2:=Range("F6")

_
, Order2:=xlDescending, Header:=xlGuess,
OrderCustom:=1, MatchCase: > >_

False, Orientation:=xlTopToBottom


[B1] = [H6].Value
[M5:P5] = [I5:L5].Value
[M5:P5].EntireColumn.AutoFit
'Ecriture du Congelé
Sheets("Ecrit").Select
[M3:P3].Select
Selection.Copy
Sheets("Prioritaire").Select
[M7:P300].Select
ActiveSheet.Paste
[M6:P300] = [M6:P300].Value
'Suppression des lignes SU
For lin = ActiveSheet.UsedRange.Rows.Count +
ActiveSheet.UsedRange.Row

To 1 Step -1
If Cells(lin, 6) = "SU" Then Rows(lin).Delete
Shift:=xlUp

Next lin

'Mise en place du temps de Trajet
[F6].Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-3],Ecrit!
R1C4:R26C5,2,FALSE)"

[F7].Select
[F6].Select
Selection.Copy
[F6:F300].Select
ActiveSheet.Paste
[F6:F300] = [F6:F300].Value
[F6:F300].Select
Selection.NumberFormat = "h:mm"
' Calcule de l'heure prevue d'arrivée
[G6].Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-2]+RC[-1])"
[G7].Select
[G6].Select
Selection.Copy
[G6:G300].Select
ActiveSheet.Paste
[G6:G300].Select
[G6:G300] = [G6:G300].Value
Selection.NumberFormat = "h:mm"
' Suppression des temps de trajet et heures departs
[E:F].Select
Selection.Delete Shift:=xlToLeft
'Inscription de l'agence expeditrice
[D6].Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],Ecrit!
R1C4:R26C6,3,FALSE)"

[D7].Select
[D6].Select
Selection.Copy
[D6:D300].Select
ActiveSheet.Paste
[C6:C300] = [D6:D300].Value
'Recherche de la l'agence destinatrice
[A6].Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[1],6)"
[A7].Select
[A6].Select
Selection.Copy
[A6:A300].Select
ActiveSheet.Paste
[A6:A300] = [A6:A300].Value
'Recherche de la l'agence destinatrice 2
[D6].Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[-3],2)"
[D7].Select
[D6].Select
Selection.Copy
[D6:D300].Select
ActiveSheet.Paste
[D6:D300] = [D6:D300].Value
[A:A].Clear
' Ecriture de l'agence destinatrice
[E:E].Select
Selection.Insert Shift:=xlToRight
[E6].Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],Ecrit!
R1C4:R27C6,3,FALSE)"

[E7].Select
[E6].Select
Selection.Copy
[E6:E300].Select
ActiveSheet.Paste
[E6:E300] = [E6:E300].Value
[D:D].Select
Selection.Delete Shift:=xlToLeft
' Ecriture des Intitulés en gras
[B5] = "Codification Navette"
[C5] = "Agence Départ"
[D5] = "Agence Destinatrice"
[E5] = "Heure Prévue"
[B4:N5].Select
Selection.Font.Bold = True
[5:5].Select
Selection.RowHeight = 20


[F:F].Select
Selection.Delete Shift:=xlToLeft
[B:N].EntireColumn.AutoFit
' Hauteur Ligne + Ecriture Frais & Congelé
[4:4].Select
Selection.RowHeight = 25
[F4:I4].Select
Selection.Merge
[F4:I4] = "Frais"
[J4:M4].Select
Selection.Merge
[J4:M4] = "Surgelé"
Cells.Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
[B4] = "domy"
[B6:M300].Borders.Weight = xlThin

' Effacement des ligne ou la colonne B est vide
derniereLigne = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For r = derniereLigne To 1 Step -1
If IsEmpty(Range("B" & r)) Then Rows(r).Clear
Next r
[B4].Clear
'Mettre des Bordures
[F4:I4].Borders.Weight = xlMedium
[J4:M4].Borders.Weight = xlMedium
[B5:M5].Borders.Weight = xlMedium
' Deplacement de l'agence
[B4] = [B1].Value
[B4:E4].Select
Selection.Merge
[B4:E4].Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With Selection.Font
.Name = "Arial"
.Size = 18
.Bold = True
End With
[1:2].Select
Selection.Delete Shift:=xlToLeft
ActiveWindow.DisplayZeros = False
' Inscription de la date
Sheets("Prioritaire").[B1].Value = Sheets("Feuil2").
[D2].Value


[A1].Select


' Preparer a imprimer
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = -2
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
End With



'Importation Ramasses
Workbooks("Importation
Elit.xls").Sheets("Prioritaire").[B305:B357].Value > >Workbooks("Transit.xls").Sheets("Ramasses").[A5:A57].Value
Workbooks("Importation
Elit.xls").Sheets("Prioritaire").[F305:J357].Value > >Workbooks("Transit.xls").Sheets("Ramasses").[N5:R57].Value
Windows("Importation Elit.xls").Activate
Sheets("Prioritaire").Select
[B304] = "Expéditeur"
[F304] = "Eur"
[G304] = "Roll"
[H304] = "Pr"
[I304] = "Eur"
[J304] = "Roll"
[F303:H303].Select
Selection.Merge
[F303:H303] = "Frais"
[I303:J303].Select
Selection.Merge
[I303:J303] = "Surgelé"
[303:303].Select
Selection.RowHeight = 25
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
[F303:J303].Borders.Weight = xlMedium
[B304:J304].Borders.Weight = xlMedium

[B303:E303].Select
Selection.Merge
[B303:E303] = "Ramasses"

[B303:J303].Select
With Selection.Font
.Name = "Arial"
.Bold = True
End With
[B303:E303].Font.Size = 18


[B305:J358].Borders.Weight = xlThin

[C305:C357].FormulaR1C1 = "=SUM(RC[3]:RC[9])"
[A305:A357].FormulaR1C1 = "=IF(RC[2]>=1,RC[1],"""")"
[B305:B357] = [A305:A357].Value
[B305:B357].HorizontalAlignment = xlLeft

' Effacement des ligne ou la colonne B est vide
[A:A].Clear
[C305:C357] = Clear
[B358] = "Total"
With Selection.Font
.Name = "Arial"
.Bold = True
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With Range("B1", Range("B360").End(xlUp)). _
SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With

Range("A1").Select



ActiveWindow.SelectedSheets.PrintOut Copies:=1


End Sub
J'ai peur que si je copie 26 fois cette macro cela
alourdit enormement mon

fichier.
Merci de votre aide


.







Avatar
Philippe.R
Bonsoir Domy,
Tu trouves un coin tranquille de ton classeur, tu saisis la liste des valeurs que tu veux pouvoir donner
au critère de tri, tu nommes cette liste mescriteres par exemple.
Dans une cellule libre de la feuille depuis laquelle tu veux lancer les différents tris, A2 par exemple,
tu places, à l'aide du menu données / validation / autoriser une liste de choix et tu modifies ta ligne
ainsi :

Selection.AutoFilter Field:, Criteria1:=[A2]

--
Amicales Salutations

Retirer A_S_ pour répondre.
XL97 / XL2002

"Domy" a écrit dans le message de news:
Oui cela apparament corspondrait a mes desirs.
Mais je ne suis pas assez caler pour le faire.

Domy


"Philippe.R" a écrit dans le message de
news:%
Bonsoir Domy,
Une des pistes proposées par François correspond plutôt bien me semble t
il à ce scénario :


soit remplacer 1800 par une variable celle ci étant [...] choisie dans
une cellule donnée de votre feuille à l'aide
d'une liste déroulante dans votre feuille reprenant les 26
valeurs et donnant la valeur du filtre dans une cellule
liée
dans ce cas, le code pourrait être adapté ainsi en utilisant la référence

de la cellule contenant

choix, Z1 par exemple :

Criteria1 = [z1]

--
Amicales Salutations

Retirer A_S_ pour répondre.
XL97 / XL2002
Pour suivre le forum :
news://msnews.microsoft.com/microsoft.public.fr.excel
(Voulez-vous vous abonner ? -> Oui)

"Domy" a écrit dans le message de
news:

Oui je peux, mais le probleme est que je n'ai pas besoin de sortir toute
les


destination d'un seul coup.
Car j'ai des infos qui arrive en permanence, donc si je pouvais sortir
que


celle qu'on me demande cela m'arrangerais.

"François" a écrit dans le message de
news:08a801c37df4$459523c0$
Bonjour,

Vous pouvez soit faire un copier coller et modifier
manuellement la ligne et le non de la macro
soit remplacer 1800 par une variable celle ci étant saisie
par l'utilisateur avec une MSGBOX ou bien correpondant à
une cellule donnée de votre feuille ou encore à l'aide
d'une liste déroulante dans votre feuille reprenant les 26
valeurs et donnant la valeur du filtre dans une cellule
liée

Bonne soirée

François



-----Message d'origine-----
Bonjour,

J'ai une grande macro, et j'ai besoin de la repete 26
fois.

Ce qui m'embete, c'est qu'il n'y a qu'une ligne que j'ai
besoin de changer.

Voila la ligne a changer :

Selection.AutoFilter Field:, Criteria1:="1800"
Cette ligne doit changer en :
Selection.AutoFilter Field:, Criteria1:="7600"
ou
Selection.AutoFilter Field:, Criteria1:="5600"
et ainsi de suite selon la destination que je cherche.

Voila la macro original pour le 1800.
Si qqun peut me depanner, je l'en remercie d'avance.