Sujet Précédent Sujet Suivant

Formule pour colorier une ligne dans une macro déjà existante

Fermé
bamboougo Messages postés 13 Date d'inscription lundi 4 mars 2013 Statut Membre Dernière intervention 5 avril 2013 - 4 mars 2013 à 10:51
bamboougo Messages postés 13 Date d'inscription lundi 4 mars 2013 Statut Membre Dernière intervention 5 avril 2013 - 6 mars 2013 à 12:03
Bonjour à tous,

Je souhaiterai ajouter une action supplémentaire à une macro déjà existante.

Je veux colorier une ligne en fonction d'une cellule :

Certaines lignes sont renseignés par un chiffre (18, 20, 40, 41 et 49).

Nous voulons colorier les lignes avec 18, 20 et 40 d'une couleur et 41 d'une autre.

Et nous voulons l'enregistrer dans une macro de mise en forme déjà existante.

Merci pour votre aide.

A voir également:

5 réponses

Réponse 1 / 5
via55 Messages postés 14494 Date d'inscription mercredi 16 janvier 2013 Statut Membre Dernière intervention 26 octobre 2024 2 734
4 mars 2013 à 12:24
Bonjour

S'agit il bien d'une macro(en VBA) ou d'une mise en forme conditionnelle
Quelle version d'Exel est utilisée?

Le mieux est de poster si possible un exemple du fichier allégé et anonymé sur cjoint.com et d'indiquer le lien fourni dans un prochain message

Cdlmnt
0
Réponse 2 / 5
bamboougo Messages postés 13 Date d'inscription lundi 4 mars 2013 Statut Membre Dernière intervention 5 avril 2013
4 mars 2013 à 12:37
Il s'agit de la vesion 2003, il s'agit bien d'une macro VBA.

Je ne peux allégé le fichier et le publier (peu de connaissances VBA) et peur de modifier la macro actuelle.

J'ai déjà voulu faire des modifs, mais impossible de l'enregistrer... Je ne connaît pas la manip pour modifier et enregistrer une macro existante.

PS : Les fichiers excel sont extraits d'une application.
0
via55 Messages postés 14494 Date d'inscription mercredi 16 janvier 2013 Statut Membre Dernière intervention 26 octobre 2024 2 734
4 mars 2013 à 13:52
Sans la macro difficile à dire !
ALT F8 ou Outils Macros pour faire apparaitre la liste des macros disponibles dans le classeur
Selectionner la macro que tu veux modifier puis Pas à pas détaillé pour voir le code
Faire un copier du code et le coller ici dans un prochain message, on y verra plus clair !
0
Réponse 3 / 5
bamboougo Messages postés 13 Date d'inscription lundi 4 mars 2013 Statut Membre Dernière intervention 5 avril 2013
4 mars 2013 à 14:13
Voici le code :


<ital>Sub PlanningEncres()
'
' PlanningEncres Macro
' Macro enregistrée le 30/11/2012 par planning.ussel
'

If LCase(Left(ActiveWorkbook.Name, 19)) <> "planning impression" Then
tto = MsgBox("Cette macro ne peut être utilisée avec ce classeur.", vbCritical, "Erreur")
Else
For Each Feuil In Sheets
Feuil.Select

' For Each s In ThisWorkbook.Worksheets

Selection.UnMerge
Range("A1").Select
ActiveCell.FormulaR1C1 = "PLANNING IMPRESSION"
Range("A1").Select
Columns("E:F").Hidden = True
Columns("J:J").Hidden = True
Columns("M:Q").Hidden = True
Columns("S:S").Hidden = True
Columns("U:X").Hidden = True
Columns("AE:AF").Hidden = True
Columns("AH:AK").Hidden = True

'reduction de la taille des colonnes

Cells.Select
With Selection.Font
.Name = "Arial"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With

Columns("A:A").Select
With Selection.Font
.Name = "Arial"
.Size = 22
End With

Columns("B:B").ColumnWidth = 20.43
Columns("A:A").ColumnWidth = 15.5
Columns("C:C").ColumnWidth = 38
Columns("R:R").Select
Columns("H:H").ColumnWidth = 12.43
Columns("I:I").ColumnWidth = 55
Columns("T:T").ColumnWidth = 16.71
Columns("K:K").ColumnWidth = 16.71
Columns("Y:AD").ColumnWidth = 21.5
Columns("AG:AG").ColumnWidth = 14.5
Columns("AL:AL").ColumnWidth = 14.5


With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
Sheets(Array("HEIDELBERG 740", "KBA II 105", "KBA 105")).Select
Sheets("HEIDELBERG 740").Activate
Columns("C:C").Select
With Selection
.HorizontalAlignment = xlLeft
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With

Selection.Copy
Columns("R:R").ColumnWidth = 35.86

Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.PageSetup.PrintArea = "$A$1:$AK$60"

Next
End If
'Mise en page avant impression
Sheets("HEIDELBERG 740").Select
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = "$A$1:$AL$60"
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = "COLORIMETRIE/PREPRESSE"
.CenterFooter = "USSEL - HEIDELBERG"
.RightFooter = "planning.ussel@chesapeakecorp.com"
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(1.5)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.511811023622047)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 2
.PrintErrors = xlPrintErrorsDisplayed
End With
Sheets("KBA 105").Select
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = "$A$1:$AL$60"
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = "COLORIMETRIE / PREPRESSE&N"
.CenterFooter = "USSEL - KBA 1"
.RightFooter = "planning.ussel@chesapeakecorp.com"
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(1.5)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.511811023622047)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 2
.PrintErrors = xlPrintErrorsDisplayed
End With
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Sheets("KBA II 105").Select
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = "$A$1:$AL$60"
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = "COLORIMETRIE/PREPRESSE"
.CenterFooter = "USSEL - KBA 2"
.RightFooter = "planning.ussel@chesapeakecorp.com"
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(1.5)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.511811023622047)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 2
.PrintErrors = xlPrintErrorsDisplayed
End With

' Efface "Field Boxmore"
Range("A4:B4").Select
Selection.ClearContents
Sheets("HEIDELBERG 740").Select
Range("A4:B4").Select
Selection.ClearContents

Sheets(Array("HEIDELBERG 740", "KBA II 105", "KBA 105")).Select
Sheets("HEIDELBERG 740").Activate

Rows("7:269").Select
With Selection.Font
.Name = "Arial"
.Size = 24
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Columns("T:T").Select
Selection.ColumnWidth = 33
Columns("Y:AD").Select
Selection.ColumnWidth = 34.86
Columns("G:G").Select
Selection.ColumnWidth = 25.57
Columns("D:D").Select
Selection.ColumnWidth = 27
Columns("B:B").ColumnWidth = 26.29
Columns("A:A").ColumnWidth = 21
Columns("H:H").Select
Selection.ColumnWidth = 16.43
Sheets(Array("HEIDELBERG 740", "KBA II 105", "KBA 105")).Select
Sheets("HEIDELBERG 740").Activate
Range("C28").Select
Sheets(Array("HEIDELBERG 740", "KBA II 105", "KBA 105")).Select
Sheets("KBA II 105").Activate
Range("C33").Select
Sheets(Array("HEIDELBERG 740", "KBA II 105", "KBA 105")).Select
Sheets("KBA 105").Activate
Range("C34").Select
End Sub</ital>
0
via55 Messages postés 14494 Date d'inscription mercredi 16 janvier 2013 Statut Membre Dernière intervention 26 octobre 2024 2 734
5 mars 2013 à 11:59
Possible que le reseau empeche
Mais là ça dépasse mes compétences !
Repose la question sur le forum en changeant le titre et en indiquant quelque chose du style probleme pour enregistrer modifications fichier sur reseau
Tu trouveras bien quelqu'un qui connait le probleme et peut etre une solution
Bonne suite
0
bamboougo Messages postés 13 Date d'inscription lundi 4 mars 2013 Statut Membre Dernière intervention 5 avril 2013
6 mars 2013 à 12:03
Merci
0
Réponse 4 / 5
bamboougo Messages postés 13 Date d'inscription lundi 4 mars 2013 Statut Membre Dernière intervention 5 avril 2013
4 mars 2013 à 16:36
Si je modifie ce code (largeur de colonne), Ou faut il enregistrer le fichier ?

Car malgré l'enregistrement à la fermeture, il faut refaire cette mise en page systémétiquement.

Merci pour votre aide.
0
via55 Messages postés 14494 Date d'inscription mercredi 16 janvier 2013 Statut Membre Dernière intervention 26 octobre 2024 2 734
4 mars 2013 à 19:38
Si tu fais une modification dans le code en principe l'enregistrement se fait automatiquement à la fermeture du classeur SAUF si une ligne de code a été mise pour empecher l'enregistrement style :

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Cancel = True
End Sub
qui annule les demandes d'enregistrement

ou
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.ThisWorkbook.Saved = True
End Sub
qui Informe Excel que le fichier a déjà été enregistré et évite donc une demande d'enregistrement à la fermeture

Il faut aller voir dans l'editeur (ALT F11) et dans This Workbook

Quant à la coloration des lignes il vaut mieux la faire par une autre macro ou plus simplement par une mise en forme conditionnelle
ex si on veut colorer une ligne de A à M si nombre 18 en colonne B
sélectionner toute la plage (allant par ex de A2 à M100)
Mise en forme conditionnelle
Nouvelle règle
Appliquer une formule .....
et entrer la formule =$B2=18 et choisir la couleur dans Format
où A2 est la 1ere cellule de la plage où trouver le nombre déclencheur
Bien respecter le$ avant la reference de colonne

Pour plusieurs conditions la formule sera =OU($B2=18;$B2=20;$B2=40)

Cdlmnt
0

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question
Réponse 5 / 5
bamboougo Messages postés 13 Date d'inscription lundi 4 mars 2013 Statut Membre Dernière intervention 5 avril 2013
5 mars 2013 à 10:39
Voici le code de la feuille à enregistrer, il n'y a pas de lignes concernant une restriction à l'enregistrement.

Le fichier est sur un réseau ? Est ce le probleme ?

Range("L6").Select
ActiveCell.FormulaR1C1 = "Objectif Vitesse"
With ActiveCell.Characters(Start:=1, Length:=16).Font
.Name = "Arial"
.FontStyle = "Gras"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("L6").Select
Selection.Font.Bold = False
Selection.Font.Bold = True
Sheets("SPERIA 106").Select
Range("L6").Select
ActiveCell.FormulaR1C1 = "Objectif vitesse"
With ActiveCell.Characters(Start:=1, Length:=16).Font
.Name = "Arial"
.FontStyle = "Gras"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("L6").Select
Selection.Font.Bold = False
Selection.Font.Bold = True
Sheets("BOBST SP 102 CER").Select
Range("L6").Select
ActiveCell.FormulaR1C1 = "Objectif vitesse"
With ActiveCell.Characters(Start:=1, Length:=16).Font
.Name = "Arial"
.FontStyle = "Gras"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("L6").Select
Selection.Font.Bold = False
Selection.Font.Bold = True
Sheets("BOBST SP 103 E").Select
Range("L6").Select
ActiveCell.FormulaR1C1 = "Objectif vitesse"
With ActiveCell.Characters(Start:=1, Length:=16).Font
.Name = "Arial"
.FontStyle = "Gras"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("L6").Select
Selection.Font.Bold = False
Selection.Font.Bold = True
Sheets("BOBST SP 76-E").Select
Range("L6").Select
With Selection.Font
.Name = "Arial"
.Size = 18
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Sheets("SPERIA 106").Select
Range("L6").Select
With Selection.Font
.Name = "Arial"
.Size = 18
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Sheets("BOBST SP 102 CER").Select
Range("L6").Select
With Selection.Font
.Name = "Arial"
.Size = 18
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Sheets("BOBST SP 103 E").Select
Range("L6").Select
With Selection.Font
.Name = "Arial"
.Size = 18
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Sheets("BOBST SP 76-E").Select
Range("L7").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-6],'Objectif découpe'!R2C1:R46C5,5,FALSE)"
Range("L7").Select
Selection.AutoFill Destination:=Range("L7:L165"), Type:=xlFillDefault
Range("L7:L165").Select
Sheets("SPERIA 106").Select
Range("L7").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-6],'Objectif découpe'!R2C1:R46C5,4,FALSE)"
Range("L7").Select
Selection.AutoFill Destination:=Range("L7:L496"), Type:=xlFillDefault
Range("L7:L496").Select
Range("L7").Select
Sheets("BOBST SP 102 CER").Select
Range("L7").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-6],'Objectif découpe'!R2C1:R46C5,3,FALSE)"
Range("L7").Select
Selection.AutoFill Destination:=Range("L7:L68"), Type:=xlFillDefault
Range("L7:L68").Select
ActiveWindow.SmallScroll Down:=-51
ActiveWindow.Zoom = 40
ActiveWindow.Zoom = 55
ActiveWindow.SmallScroll Down:=-9
ActiveWindow.SmallScroll ToRight:=-5
Sheets("BOBST SP 103 E").Select
Range("L7").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP('Objectif découpe'!R2C1:R46C5,2,FALSE)"
Range("L7").Select
Selection.AutoFill Destination:=Range("L7:L109"), Type:=xlFillDefault
Range("L7:L109").Select
ActiveWindow.SmallScroll Down:=-105
Range("L7").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-6],'Objectif découpe'!R2C1:R46C5,2,FALSE)"
Range("L7").Select
Selection.AutoFill Destination:=Range("L7:L109"), Type:=xlFillDefault
Range("L7:L109").Select
ActiveWindow.SmallScroll Down:=-114
Sheets("BOBST SP 76-E").Select
Range("A1:N1").Select
End Sub

Merci pour votre aide.
0

Discussions similaires

je veut créer des codes
jonkiller -
Nhhi -

20 réponses
Que veut dire "correspondant occupé" lors d'un appel ?
veroaaa -
Pat -

10 réponses