Autres [RÉSOLU] Modification police copy avec macro

un internaute

XLDnaute Impliqué
Bonjour le forum
Dans la macro ci-dessous je voudrais faire une copy de la colonne dates (colonne A) qui sont en police Arial 12 en Colonne M (voir macro) mais Arial 10 avec couleur de fond vert clair (couleur 35) et police 10 bleu (couleur 5)

Merci pour vos éventuels retours

Cordialement


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Target.Address = "$A$3" Then
InitBEROCCA 'Module posologie
Target = IIf(Target.Value = Application.Proper(Format(Date, "dddd dd mmmm yyyy")), "", Date): Cancel = True
ElseIf Target.Address = "$A$2" Then
Columns("K:M").Hidden = Not Columns("K:M").Hidden
Cancel = True
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Ligne
Dim NbInr As Integer, NbLigne As Long
Dim Cel As Range


If Target.Address = "$A$3" Then
Application.ScreenUpdating = False
Application.EnableEvents = False

If Target = "" Then
Range("A3:C102").ClearContents
Ligne = Application.Max(3, Range("E" & Rows.Count).End(xlUp).Row)
If Range("H" & Ligne) = "" Then
Range("E" & Ligne & ",G" & Ligne & ":J" & Ligne).ClearContents
End If
Else
Range("C3") = "TOTO"
Range("B3") = Posologie
Range("E" & Rows.Count).End(xlUp).Offset(1, 0) = NBPriseJour

' Début Partie Modifié le 24/01/2020
Range("I" & Rows.Count).End(xlUp).Offset(1, 0) = Range("A" & Target.Row)
Range("G" & Rows.Count).End(xlUp).Offset(1, 0) = Application.Proper(Format(Range("A" & Target.Row), "dddd dd mmmm yyyy"))
' Fin Partie Modifié le 24/01/2020

Range("A3").AutoFill Destination:=Range("A3:A102"), Type:=xlFillSeries
Range("A3:A102").Copy Range("M3")
With Range("M3:M102")
.NumberFormat = "m/d/yyyy"
.FormatConditions.Delete
End With
With Range("N3:N102")
.Formula = "=PROPER(TEXT(A3,""jjjj jj mmmm aaaa""))"
.Copy
Range("A3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.ClearContents

End With

Application.CutCopyMode = False

NbLigne = 99 '102 - Target.Row
Range("B3").AutoFill Destination:=Range("B3").Resize(Application.Min(NbJour, NbLigne))

' Début Partie Modifié le 24/01/2020
Ligne = Range("I" & Rows.Count).End(xlUp).Row
Range("H" & Ligne) = Application.Proper(Format(DateAdd("d", NbJour - 1, Range("I" & Ligne)), "dddd dd mmmm yyyy"))
Range("J" & Ligne) = DateAdd("d", NbJour - 1, Range("I" & Ligne))
' Fin Partie Modifié le 24/01/2020
End If
End If

Init_Feuille
Range("A3").Select
Application.EnableEvents = True
End Sub
 
Dernière édition:

jpb388

XLDnaute Accro
Bonjour à tous
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
      Dim Ligne
      Dim NbInr As Integer, NbLigne As Long
      Dim Cel As Range


      If Target.Address = "$A$3" Then
            Application.ScreenUpdating = False
            Application.EnableEvents = False
            If Target = "" Then
                  Range("A3:C102").ClearContents
                  Ligne = Application.Max(3, Range("E" & Rows.Count).End(xlUp).Row)
                  If Range("H" & Ligne) = "" Then
                        Range("E" & Ligne & ",G" & Ligne & ":J" & Ligne).ClearContents
                  End If
            Else
                  Range("C3") = "TOTO"
                  Range("B3") = Posologie
                  Range("E" & Rows.Count).End(xlUp).Offset(1, 0) = NBPriseJour
                  
                  ' Début Partie Modifié le 24/01/2020
                  Range("I" & Rows.Count).End(xlUp).Offset(1, 0) = Range("A" & Target.Row)
                  Range("G" & Rows.Count).End(xlUp).Offset(1, 0) = Application.Proper(Format(Range("A" & Target.Row), "dddd dd mmmm yyyy"))
                  ' Fin Partie Modifié le 24/01/2020
                  
                  Range("A3").AutoFill Destination:=Range("A3:A102"), Type:=xlFillSeries
                  Range("A3:A102").Copy Range("M3")
                  With Range("M3:M102")
                        .NumberFormat = "m/d/yyyy"
                        .FormatConditions.Delete
                        .Interior.ColorIndex = 10
                        With .Font
                              .Name = "Arial"
                              .Size = 10
                              .ColorIndex = 10
                        End With
                  End With
                  With Range("N3:N102")
                        .Formula = "=PROPER(TEXT(A3,""jjjj jj mmmm aaaa""))"
                        .Copy
                        Range("A3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                        .ClearContents
                  End With
                  
                  Application.CutCopyMode = False
                  
                  NbLigne = 99 '102 - Target.Row
                  Range("B3").AutoFill Destination:=Range("B3").Resize(Application.Min(NbJour, NbLigne))
                  
                  ' Début Partie Modifié le 24/01/2020
                  Ligne = Range("I" & Rows.Count).End(xlUp).Row
                  Range("H" & Ligne) = Application.Proper(Format(DateAdd("d", NbJour - 1, Range("I" & Ligne)), "dddd dd mmmm yyyy"))
                  Range("J" & Ligne) = DateAdd("d", NbJour - 1, Range("I" & Ligne))
                  ' Fin Partie Modifié le 24/01/2020
            End If
      End If

      Init_Feuille
      Range("A3").Select
      Application.ScreenUpdating = True
      Application.EnableEvents = True
End Sub
 

Discussions similaires

Réponses
7
Affichages
292

Statistiques des forums

Discussions
311 711
Messages
2 081 799
Membres
101 818
dernier inscrit
tiftouf5757