Autres [RÉSOLU] Modification police copy avec macro

[un internaute]

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

 

[jpb388]

Bonjour à tous

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

 

[un internaute]

Bonjour Jpb388
SUPER c'est mieux que ce GRAND pavé gris.
Serait-il possible de faire effacer au double clic Sur A3 mais sans trop de casse!!!
Si trop de modifs ne te casse pas la t^te la-dessus
D'avance merci

​

 

[jpb388]

effacer quoi ? la feuille, la colonne M, le formatage de la colonne M ??

 

[un internaute]

Oh! P$$$$N? quel C$n
Oui la colonne M
Toutes mes excuses

 

[jpb388]

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
            With Range("M3:M102")
                  .Interior.ColorIndex = -4142
                  .Font.ColorIndex = 1
            End With
                        
End Sub

 

[un internaute]

Re
ça n'efface pas alors j'ai mis

            With Range("M3:M102")

                  .Interior.ColorIndex = 35

                  .Font.ColorIndex = 35

            End With

Ton avis s'il te plaît?
Merci à toi

 

[jpb388]

je pensai au formatage mais pour tout effacer
Range("M3:M102").Clear

 

[un internaute]

Merci SUPER.
Avec toutes mes excuses pour ma question.
Je pense que vous y êtes habitués maintenant!!!
Encore merci
Bonne fin de WE

 

[Staple1600]

Bonjour le fil

Et pour ceux qui comme moi ont mal aux doigts le dimanche
[M3:M102].Clear
peut suffire et fera la même chose.