Macro for breaking list into sections using underline

[jdmc45]

Hi,

I am trying to create a macro to put a top border on the row when a selection in a row changes. There are only 3 selections so will be 2 lines per worksheet. So, Column C will be

Apples
Apples
Apples
Oranges
Oranges
Bananas
Bananas
Bananas
Bananas

I would like to have a line between Apples and Oranges and Oranges and Bananas, that is, whenever the value in the column changes. My code thus far is:

Sub Line()
Dim M As Long, i As Long
M = Range("C4:C2000")
For i = 0 To M
If Range("C" & i + 4) = "Apples" Then i = i + 1
If Range("C" & (i - 1) + 4) = "Apples" And Range("C" & i + 4) = "Oranges" Then
    
Range("C" & (i - 1) + 4).Select
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
Next i
     
If Range("C" & i + 4) = "Oranges" Then i = i + 1
If Range("C" & (i - 1) + 4) = "Oranges" And Range("C" & i + 4) = "Bananas" Then
Range("C" & (i - 1) + 4).Select
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
End If
End Sub

Any help will be much appreciated!!

 

[Leith Ross]

Hello jdmc45,

This will start will cell "C4" and go down column "C" to the last cell that has as value. Each group will be underlined.

Sub UnderlineGroups()

   Dim Cell As Range
   Dim Prev As Variant
   Dim Rng As Range
   Dim RngEnd As Range
   Dim Wks As Worksheet
   
     Set Wks = ActiveSheet
     
     Set Rng = Range("C4")
     Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
     If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd)
     
       For Each Cell In Rng
         If IsEmpty(Prev) Then Prev = Cell.Value
         If Cell.Value <> Prev Then
            Prev = Cell.Value
            With Cell.Borders(xlEdgeTop)
              .LineStyle = xlContinuous
              .Weight = xlThin
            End With
         End If
       Next Cell
   
End Sub

Sincerely,
Leith Ross

 

[jdmc45]

Thanks so much for that Leith! Just one more thing, I wasn't specific enough but I would actually like to create the under/overline for rows C to J, what extra code is needed to perform this?

Thanks again for your time,

James

 

[jdmc45]

So to confirm, the condition depends on column C, the under/over line covers rows C to J.

 

[jdmc45]

any ideas?

 

[Leith Ross]

Hello jdmc45,

Sorry, I was feeding my cats. This will extend the line across to column "J".

Sub UnderlineGroups()

   Dim Cell As Range
   Dim Prev As Variant
   Dim Rng As Range
   Dim RngEnd As Range
   Dim Wks As Worksheet
   
     Set Wks = ActiveSheet
     
     Set Rng = Range("C4")
     Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
     If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd)
     
       For Each Cell In Rng
         If IsEmpty(Prev) Then Prev = Cell.Value
         If Cell.Value <> Prev Then
            Prev = Cell.Value
            With Cell.Resize(ColumnsSize:=7).Borders(xlEdgeTop)
              .LineStyle = xlContinuous
              .Weight = xlThin
            End With
         End If
       Next Cell
   
End Sub</pre>

 

[jdmc45]

You an are excel legend Leith! Thank you!

For anyone else who wants to use this code, this is a tiny syntax error, the column sizing line of code should read

With Cell.Resize(ColumnSize:=8).Borders(xlEdgeTop)

It is Column, not Columns, and it is inclusive of column c so the ColumnSize will be 8.

Thanks again!

 

[Leith Ross]

Hello jdmc45,

Oops, sorry about that. Nice catch and correction.