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

bamboougo Messages postés 16 Statut Membre -  
bamboougo Messages postés 16 Statut Membre -
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.

5 réponses

  1.
    via55 Messages postés 14391 Date d'inscription   Statut Membre Dernière intervention   2 759
     
    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
  2. bamboougo Messages postés 16 Statut Membre
     
    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
    1. via55 Messages postés 14391 Date d'inscription   Statut Membre Dernière intervention   2 759
       
      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
  3. bamboougo Messages postés 16 Statut Membre
     
    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
    1. via55 Messages postés 14391 Date d'inscription   Statut Membre Dernière intervention   2 759
       
      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
    2. bamboougo Messages postés 16 Statut Membre
       
      Merci
      0
  4. bamboougo Messages postés 16 Statut Membre
     
    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
    1. via55 Messages postés 14391 Date d'inscription   Statut Membre Dernière intervention   2 759
       
      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

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

    Posez votre question
  6. bamboougo Messages postés 16 Statut Membre
     
    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