Macro équivalente MFC sans MFC (changer épaisseur bordure)

Bonjour,

Suite a mon post du 23/06 lors duquel j'avais sollicité l'aide du forum, JFL m'avait grandement aidé (cf https://forum.excel-pratique.com/excel/action-si-les-donnees-des-cellules-de-deux-ligne-a-la-suite-d...) en solutionnant mon problème en me suggérant d'utiliser la MFC (Mise en forme conditionnelle) afin de solutionner mon problème, ce qui a marché dans un premier temps, mais, voulant rendre plus évidente la séparation avec un trait plus épais, je me suis rendu compte suite a mes recherches que cela était impossible, MFC n'autorisant pas a changer l'épaisseur des bordures (du moins l'épaissir).

J'avais donc a l'époque crée une macro en essayant de changer .Weight = xlThin par .Weight = xlThick mais comme dit plus haut, MFC ne le permet pas. Je me demandais donc si il existait une manière simple et efficace de contourner ce problème, n'étant pas forcément très a l'aise avec les macro en général.

Pour info, le type de document sur lequel cela doit s'appliquer est ci-joint (pour rappel je cherche juste a établir une démarcation entre les rendez-vous dont l'heure/minute diffère), une macro comme solution finale est ce que je recherche idéalement comme il faudrait que n'importe qui puisse effectuer cette tache sur la simple pression d'un bouton idéalement, la macro que j'utilise actuellement est la suivante :

Sub MacroMinute()
'
' MacroMinute Macro
'

'
Range("B2:B120000").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=MINUTE($B2)<>MINUTE($B3)"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Borders(xlBottom)
.LineStyle = xlContinuous
.ColorIndex = 3
.TintAndShade = 0
.Weight = xlThin
End With
Selection.FormatConditions(1).StopIfTrue = False
End Sub

Bonjour,

Un test qui prend cependant quelques secondes pour s’exécuter chaque ligne étant comparée à la suivante une a une :

Sub CRENEAUX()
Dim LR As Long, L As Long
Application.ScreenUpdating = False
With Worksheets("Sheet0")
    LR = .Cells(.Rows.Count, 1).End(xlUp).Row
    .UsedRange.Borders.LineStyle = xlNone
    For L = 1 To LR
        If .Cells(L, 1) & .Cells(L, 2) & .Cells(L, 3) <> .Cells(L, 1).Offset(1) & .Cells(L, 2).Offset(1) & .Cells(L, 3).Offset(1) Then
            With .Cells(L, 1).Resize(, 29).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlThick
            End With
        End If
    Next L
End With
Application.ScreenUpdating = True
End Sub

Cdlt,

Bonjour,

Merci de la réponse rapide et efficace, en effet, après essai, la Macro fonctionne et remplit parfaitement ce qui est attendu.

A moi maintenant d'essayer de tout comprendre dans ce code pour pouvoir faire des modifications facultative si besoin par exemple éviter qu'il prenne en compte les 'en-tetes' et tracer une ligne rouge entre ceux-ci et le premier RDV et/ou limiter le trait rouge a la seule colonne de la date.

Encore merci pour l'aide éclair Ergotamine!

Bonjour,

Je vous le rajoute en commenté :

Sub CRENEAUX()
Dim LR As Long, L As Long 'Défini le type des variables dernière ligne LR, ligne L comme numérique Long
Application.ScreenUpdating = False 'On désactive la MàJ à l'écran
With Worksheets("Sheet0") 'Avec la feuille Sheet0
    LR = .Cells(.Rows.Count, 1).End(xlUp).Row 'On défini LR sur la base de la dernière cellule pleine de la colonne 1
    .UsedRange.Borders.LineStyle = xlNone 'On retire toutes les bordures de la feuille Sheet0 (Reset si la plage a été modifiée)
    For L = 1 To LR 'Pour chaque L entre la 1ère de la feuille et LR
        If .Cells(L, 1) & .Cells(L, 2) & .Cells(L, 3) <> .Cells(L, 1).Offset(1) & .Cells(L, 2).Offset(1) & .Cells(L, 3).Offset(1) Then
        'Si les cellules de la lignes des colonnes 1, 2 et 3 (A, B et C) sont différentes des cellules de la ligne d'en dessous (via Offset(1))
            With .Cells(L, 1).Resize(, 29).Borders(xlEdgeBottom) 'Avec la bordure inférieure de la ligne L sur les 29 premières colonnes (resize)
                .LineStyle = xlContinuous 'On applique une bordure continue
                .Weight = xlThick 'On applique une bordure épaisse
            End With
        End If
    Next L 'On passe à la ligne suivante
End With
Application.ScreenUpdating = True 'On réactive la MàJ à l'écran
End Sub

Si vous ne souhaitez pas prendre en compte les en tête, il suffit de modifier le 1 de L = 1 to LR en l'adaptant à votre première ligne de RdV à contrôler.
Pour la ligne rouge, il faut soit :
- Modifier UsedRange en limitant la plage tel que .Range("A2:AC" & LR) ainsi les bordures d'en tête ne seront pas supprimée
- Après UsedRange, réappliquer les bordures sur l'en tête

Bref je vous laisse adapter et tatôner mais ce que vous demandez est possible.

Cdlt,

Incroyable ! Je n'aurais jamais osé le demander!

Milles mercis pour les commentaires dans le code et dans votre post, cela va me permettre de comprendre tout ceci beaucoup plus vite!

Bonjour

Bonjour à tous

Une variante qui permet de vérifier un temps minimum entre 2 rendez-vous.

Option Explicit

Dim tablo
Dim i&, dm!

Sub Verif()

    Application.ScreenUpdating = False
    tablo = Range("A1:B" & Range("A" & Rows.Count).End(xlUp).Row)
    Range("A1").CurrentRegion.Borders.LineStyle = xlNone
    For i = 2 To UBound(tablo, 1) - 1
        tablo(i, 1) = Replace(tablo(i, 1), ".", "-")
        tablo(i + 1, 1) = Replace(tablo(i, 1), ".", "-")
        If CDate(tablo(i, 1)) * 1 + CDate(tablo(i, 2)) * 1 = CDate(tablo(i + 1, 1)) * 1 + CDate(tablo(i + 1, 2)) * 1 Then
            Range("A" & i & ":AC" & i).Borders(xlBottom).Weight = xlThick
        End If
    Next i
End Sub

Sub VerifInf15()

    Application.ScreenUpdating = False
    tablo = Range("A1:B" & Range("A" & Rows.Count).End(xlUp).Row)
    Range("A1").CurrentRegion.Borders.LineStyle = xlNone
    dm = 15 / 24 / 60                                           'durée maxi ; ici, 15 pour 15 mn ; modifiable
    For i = 2 To UBound(tablo, 1) - 1
        tablo(i, 1) = Replace(tablo(i, 1), ".", "-")
        tablo(i + 1, 1) = Replace(tablo(i, 1), ".", "-")
        If CDate(tablo(i, 1)) * 1 + CDate(tablo(i, 2)) * 1 > CDate(tablo(i + 1, 1)) * 1 + CDate(tablo(i + 1, 2)) * 1 - dm Then
            Range("A" & i & ":AC" & i).Borders(xlBottom).Weight = xlThick
        End If
    Next i
End Sub

Bye !