highlights every other row

[pedy]

Hi,

I have this bit of code that highlights every other row. I would like to modify it so that it doesn't highlight the entire rows but instead stops at the column of whichever cell contains data.

For instance if I’m using a block of cells such as A1 to C5 it would highlight A2-B2-C2 & A4-B4-C4 only. Later on if I insert data in D3 it would now highlight A2-B2-C2-D2 & A4-B4-C4-D4. Anytime that data would be inserted into a new column all row highlight would now adapt to the new length of the table.

Here’s the code:

Sub ShadeEverySecondRow()
Dim lRow As Long
lRow = 0
Do
lRow = lRow + 2
If IsEmpty(Cells(lRow, 1)) Then Exit Do
Rows(lRow).Interior.ColorIndex = 15
Loop
End Sub


Any help is appreciated

Pedy

 

[erik.van.geit]

Not sure
this perhaps?

    With Range(Cells(2, 1), Cells(lRow, LC)).Borders
        For i = 7 To 10
            With .Item(i)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
            End With
        Next i
    End With

You can edit the "range" line yourself if needed.

Or did you want a border around at each line?

 

[erik.van.geit]

just watched the hour: must go in 5 minutes
if you need a border around each line, try this

    For lRow = 2 To LR Step 2
        With Range(Cells(lRow, 1), Cells(lRow, LC))
        .Interior.ColorIndex = 15
            With .Borders
                For i = 7 To 10
                    With .Item(i)
                    .LineStyle = xlContinuous
                    .Weight = xlThin
                    .ColorIndex = xlAutomatic
                    End With
                Next i
            End With
        End With
    Next lRow

 

[pedy]

Using a bit of your first post "Not sure", it almost works as I need. Here’s what I have (hoping that I did kill any tags again):


Public Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

Dim lRow As Long
Dim LR As Long
Dim LC As Long

With ActiveSheet.Cells
.Interior.ColorIndex = xlNone

.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone

LR = .Find("*", .Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False, False).Row
LC = .Find("*", .Cells(1, 1), xlFormulas, xlPart, xlByColumns, xlPrevious, False, False).Column
End With

lRow = 0

For lRow = 2 To LR Step 2
Range(Cells(lRow, 1), Cells(lRow, LC)).Interior.ColorIndex = 15

Next lRow

With Range(Cells(1, 1), Cells(lRow, LC)).Borders
For i = 7 To 10
With .Item(i)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Next i
End With

End Sub

However there are 2 things that don’t seem to work very well.

1) On the border, it skips a row at the bottom &
2) When data is added or removed, the highlight adjusts but not the borders. I thought that by using the 4 “.Borders(xlEdgeLeft).LineStyle = xlNone”, it would initialize the borders onSave…

Any ideas ?

Pedy

 

[erik.van.geit]

You should really do a search on the board how to use the codetags, it's quite simple: put your code between:

 and

Sub format_table()
Dim lRow As Long
Dim LR As Long
Dim LC As Long
Dim Sht As Worksheet
Application.ScreenUpdating = False
On Error GoTo skip
    With Sheets("SheetName")
        With .Cells
        .Interior.ColorIndex = xlNone
        .Borders.LineStyle = xlNone
        LR = .Find("*", .Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False, False).Row
        LC = .Find("*", .Cells(1, 1), xlFormulas, xlPart, xlByColumns, xlPrevious, False, False).Column
        End With
    lRow = 0
        For lRow = 2 To LR Step 2
        .Range(.Cells(lRow, 1), .Cells(lRow, LC)).Interior.ColorIndex = 15
        Next lRow
    
        With .Range(.Cells(1, 1), .Cells(LR, LC)).Borders
            For i = 7 To 10
                With .Item(i)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
                End With
            Next i
        End With
    End With
    
skip:
    If Err Then
    MsgBox Err.Description, vbCritical, "ERROR"
    End If
Application.ScreenUpdating = True
On Error GoTo 0
End Sub

 

[erik.van.geit]

Board shut down here just before I replied with a long text.
Could save the code and first sentence but must now go quickly. More explanation will follow later this evening.

 

[pedy]

Ok thanks.

NOT SHOUTING JUST TESTING codetags

Pedy

 

[pedy]

I was finaly able to test your last code posting.

That works exactly as I needed. Thanks so much !!!

P
   e
      d
         y

 

[erik.van.geit]

O, dear, I was quite lucky some hours ago. I was not home and wrote a lot, but it was all lost, except for the code which was still on the ClipBoard Also about the codetags, but that you found out.

Nevermind, here we are again.
Instead of putting all your code in the BeforeSave event, you would better put it in a regulat module. That way you can call the code from anywhere.

Public Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
format_table
End Sub

Here is the code again, the way I like it formatted (this Board keeps "cleaning up" empty lines )

Sub format_table()
Dim lRow As Long
Dim LR As Long
Dim LC As Long
Dim Sht As Worksheet
 
Application.ScreenUpdating = False
 
On Error GoTo skip
 
    With Sheets("SheetName")
 
        With .Cells
        .Interior.ColorIndex = xlNone
        .Borders.LineStyle = xlNone
        LR = .Find("*", .Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False, False).Row
        LC = .Find("*", .Cells(1, 1), xlFormulas, xlPart, xlByColumns, xlPrevious, False, False).Column
        End With
 
    lRow = 0
 
        For lRow = 2 To LR Step 2
        .Range(.Cells(lRow, 1), .Cells(lRow, LC)).Interior.ColorIndex = 15
        Next lRow
 
        With .Range(.Cells(1, 1), .Cells(LR, LC)).Borders
            For i = 7 To 10
                With .Item(i)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
                End With
            Next i
        End With
 
    End With
 
skip:
    If Err Then
    MsgBox Err.Description, vbCritical, "ERROR"
    End If
 
On Error GoTo 0
 
Application.ScreenUpdating = True
 
End Sub

in case the sheet is empty or protected or ...

On Error GoTo skip

to clear all lines

.Borders.LineStyle = xlNone

This part could be more elaborated to provide better feedback to the user, but doesn't look worth the effort if you are the only user

    If Err Then
    MsgBox Err.Description, vbCritical, "ERROR"
    End If

kind regards,
Erik

 

[pedy]

Hi Erik,

I wonder if I may, make a request to modify the results of this code?

It will happen that there will be many different little groups to be bordered so I would like the border to look for 2 specific words to begin and end the borders. Let's say word1 & word2. The border should begin after (under) word1 and end before (above) word2.

Also, would it be possible to every cell (xlEdgeBottom, xlEdgeTop, xlEdgeRight & xlEdgeLeft) please?

Pedy

 

[pedy]

So far I have this:

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

Dim lRow As Long
Dim LR1 As Long
Dim LR2 As Long
Dim LC As Long

    With ActiveSheet.Cells
    .Interior.ColorIndex = xlNone
    .Borders.LineStyle = xlNone
        
        .Borders(xlEdgeLeft).LineStyle = xlNone
        .Borders(xlEdgeTop).LineStyle = xlNone
        .Borders(xlEdgeBottom).LineStyle = xlNone
        .Borders(xlEdgeRight).LineStyle = xlNone

    LR1 = .Find("word1", .Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False, False).Row + 1
    LR2 = .Find("word2", .Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False, False).Row - 1
    LC = .Find("*", .Cells(1, 1), xlFormulas, xlPart, xlByColumns, xlPrevious, False, False).Column
    End With

lRow = 0

    For lRow = LR1 To LR2 Step 1 'LR1 is "word1" - "LR2 is "word2:"
        With Range(Cells(lRow, 1), Cells(lRow, LC))
        
        .Interior.ColorIndex = 24
            With .Borders
                For i = 7 To 11
                    With .Item(i)
                    .LineStyle = xlDot
                    '.Weight = xlThin
                    .ColorIndex = xlAutomatic
                    End With
                Next i
            End With
        End With
    Next lRow
        
End Sub

This woks but only for 1 occurence of word1 & word2 (from the bottom up) . The others are ignored

Pedy