Solved: Excel 2003 - Highlighted row using top & bottom borders. Would like to speed up code
I wrote this code in my selection change event to highlight the selected row using top and bottom borders. It works well except that with 15,000 rows it's a little slower than I would like, taking about 2 seconds for each selection change.
Any ideas on how it can be coded to run faster?
I've attached a sample workbook.
Thanks
[vba]
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
[vba]Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static TheRow
Application.ScreenUpdating = False
Dim LastRow As Long
'ActiveSheet.DisplayAutomaticPageBreaks = False 'in a sheet activate event instead?
LastRow = Range("A" & Rows.Count).End(xlUp).Row
With TheRow
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
'.Borders(xlInsideHorizontal).LineStyle = xlNone 'needed?
End With
If ActiveCell.Row > 15 Then
If Target.Rows.Count = 1 And Target.Row < LastRow Then
Set TheRow = Target.EntireRow.Resize(, 17)
With TheRow.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 7
End With
With TheRow.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 7
End With
End If
End If
Range("A15:Q15").Interior.ColorIndex = 15
Cells(15, ActiveCell.Column).Interior.ColorIndex = 45
Application.ScreenUpdating = True
End Sub
[/vba] It will also tidy things up to add another event, say workbook_open or sheet_activate, to remove highlighting left over from when the workbook is saved as TheRow will be forgotten/not exist when the workbook is first opened.
p45cal Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.
Unfortunately when I try to run your code I get a runtime error 424 Object required with this line highlighted yellow .Borders(xlEdgeTop).LineStyle = xlNone
I've attached a sample workbook to demonstrate the error.
Oh yes.., need to check TheRow exists on first run:
[vba]
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static TheRow As Range
Application.ScreenUpdating = False
Dim LastRow As Long
'ActiveSheet.DisplayAutomaticPageBreaks = False 'in a sheet activate event instead?
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row If Not TheRow Is Nothing Then
With TheRow
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
'.Borders(xlInsideHorizontal).LineStyle = xlNone 'needed?
End With End If
If ActiveCell.Row > 15 Then
If Target.Rows.Count = 1 And Target.Row < LastRow Then
Set TheRow = Target.EntireRow.Resize(, 17)
With TheRow.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 7
End With
With TheRow.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 7
End With
End If
End If
Range("A15:Q15").Interior.ColorIndex = 15
Cells(15, ActiveCell.Column).Interior.ColorIndex = 45
Application.ScreenUpdating = True
End Sub
[/vba]or killing two birds with one stone, so you don't have to have to worry about TheRow being forgotten between saving and opening the workbook:
[vba]
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static TheRow As Range
Application.ScreenUpdating = False
Dim LastRow As Long
'ActiveSheet.DisplayAutomaticPageBreaks = False 'in a sheet activate event instead?
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row If TheRow Is Nothing Then Set TheRow = Range("A1:Q" & LastRow - 1)
With TheRow
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
'.Borders(xlInsideHorizontal).LineStyle = xlNone 'needed?
End With
If ActiveCell.Row > 15 Then
If Target.Rows.Count = 1 And Target.Row < LastRow Then
Set TheRow = Target.EntireRow.Resize(, 17)
With TheRow.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 7
End With
With TheRow.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 7
End With
End If
End If
Range("A15:Q15").Interior.ColorIndex = 15
Cells(15, ActiveCell.Column).Interior.ColorIndex = 45
Application.ScreenUpdating = True
End Sub
[/vba]
Last edited by p45cal; 12-15-2010 at 03:36 AM.
p45cal Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.
Thanks a bunch. That works great. And is super fast being that only the target row has to be dealt with. I would have never worked that out on my own.
The best that I could come up with as far as highlighting the previously select row and selecting the same cell when the workbook is closed and re-opened, was by using the Before Close and Before Open events as shown below. I'm sure it can be more elegantly coded, but it's fast and seems to be working fine.
I've attached a sample workbook with all of the code.
Thanks so much for sharing your time and skill, as your method is so, so much faster.
[vba]Private Sub Workbook_BeforeClose(Cancel As Boolean)
I should test thoroughly before I post,try (slow only for the first selection change after opening the workbook):
[vba]
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static TheRow As Range
Application.ScreenUpdating = False
Dim LastRow As Long
'ActiveSheet.DisplayAutomaticPageBreaks = False 'in a sheet activate event instead?
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
If TheRow Is Nothing Then
With Range("A1:Q" & LastRow - 1)
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone 'yes needed here
End With
Else
With TheRow
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
'.Borders(xlInsideHorizontal).LineStyle = xlNone 'needed? No
End With
End If
If ActiveCell.Row > 15 Then
If Target.Rows.Count = 1 And Target.Row < LastRow Then
Set TheRow = Target.EntireRow.Resize(, 17)
With TheRow.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 7
End With
With TheRow.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 7
End With
End If
End If
Range("A15:Q15").Interior.ColorIndex = 15
Cells(15, ActiveCell.Column).Interior.ColorIndex = 45
Application.ScreenUpdating = True
End Sub
[/vba]
p45cal Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.
Well, that works, and being slow only with the first selection is not an issue, but your previous code along with the open and close events that I coded is fast with the first and every selection. Plus my code does allow your code to add the row borders to the previously selected row and select the same cell that was selected when the workbook was closed.
The 1 to 1 1/2 second saving's may possibly being traded off for a slower opening and closing time, but I'm not noticing it.
If you have time try out the sample workbook in my last post, to see what you think.
Rather than in a before_close event, it might be better in a before_save event. Why?
1. The close event takes place after the save event, so your changes may not be saved.
2. If someone saves the workbook then closes it they get asked AGAIN, if they want to save it. Usually, since they may have already just saved it they may choose No.
Users usually expect, on opening a workbook to be on the same sheet and cell(s) as when they closed it. This may not happen with these open and close event handlers. (A sheet gets selected on open and since you've stored the activecell address rather than the selection, if the user has left a block of cells selected on sheet1, he'll find that only one cell is selected on reopening.
I prefer all code related to something to be in one place.
There'll be no noticeable speed cost to getting up and running from opening the workbook, and likewise while using the sheet, with my last suggestion in msg #6 and removing the open and close events.
p45cal Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.
Excel - Need help spotting a bug. The code is mysteriously adding a right side border
I've attached a sample workbook. Can anyone spot why a right side red border is being added to column k of the selected row when I have Column's M thru L hidden and a filter applied?
[VBA]Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static TheRow As Range
Application.ScreenUpdating = False
Dim Lastrow As Long
Lastrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
If TheRow Is Nothing Then
With Range("A1:Q" & Lastrow - 1)
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
Else
With TheRow
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
End With
End If
If ActiveCell.Row > 15 Then
If Target.Rows.Count = 1 And Target.Row < Lastrow Then
Set TheRow = Target.EntireRow.Resize(, 17)
With TheRow.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 7
End With
With TheRow.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 7
End With
End If
End If
Range("A15:Q15").Interior.ColorIndex = 15
Cells(15, ActiveCell.Column).Interior.ColorIndex = 45
Application.ScreenUpdating = True
End Sub[/VBA]
I've been trying to see if I can solve my problem by coloring only the borders of the visible cells, but the way that I have attempted that is causing me problems. I get an Application, or Object Defined Error with the command Set TheRow = Target.EntireRow.Resize(, 17)
But if I unhide the columns it works fine.
If I change the resize to 15, the error is avoided but the loop struggle's taking about 7 seconds and ofcourse the coloring is not done for the last two columns.
Any help will be much appreciated
[vba]
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static TheRow As Range
Dim Lastrow As Long
Static aCell As Range
Lastrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
If TheRow Is Nothing Then
With Range("A1:Q" & Lastrow)
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
Else
With TheRow
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
End With
End If
If ActiveCell.Row > 15 Then
If Target.Rows.Count = 1 And Target.Row < Lastrow Then
'On Error Resume Next
Set TheRow = Target.EntireRow.Resize(, 17)
'On Error GoTo 0
Set TheRow = TheRow.SpecialCells(xlVisible)
If Not TheRow Is Nothing Then
For Each aCell In TheRow
With aCell.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 7
End With
With aCell.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 7
End With
Next
End If
End If
End If
Range("A15:Q15").Interior.ColorIndex = 15
Cells(15, ActiveCell.Column).Interior.ColorIndex = 45
Application.ScreenUpdating = True
End Sub
[/vba]
I couldn't reproduce the "right side red border is being added to column k ", however I did see a problem with the row borders highlight not being removed from cells in columns which were hidden when the autofilter was active. I liked your idea of highlighting one cell at a time to try to circumvent the problem, which I've used below - it works ok here, try it on your system. It might be good enough for your purposes.
The line setting therow to specialcells(xlvisible) seems to fire the selection_change event - loopwise so it iterates 'til it's sick of it (the several seconds delay), so I haven't used it.
We're having to circumvent some slightly buggy Excel behaviour here.
The reason you got the object defined error was because target had become two areas (the result of previously setting therow to specialcells(xlvisible)) which then fired another selection_change event, so it didn't like using .EntireRow with two non-contiguous ranges (even if they are on the same row!).
[vba]
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static TheRow As Range
Application.ScreenUpdating = False
Dim Lastrow As Long
Dim cll as Range
Lastrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
If TheRow Is Nothing Then
With Range("A1:Q" & Lastrow - 1)
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
Else
For Each cll In TheRow.Cells
cll.Borders(xlEdgeTop).LineStyle = xlNone
cll.Borders(xlEdgeBottom).LineStyle = xlNone
Next cll
End If
If ActiveCell.Row > 15 Then
If Target.Rows.Count = 1 And Target.Row < Lastrow Then
Set TheRow = Target.EntireRow.Resize(, 17)
With TheRow.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 7
End With
With TheRow.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 7
End With
End If
End If
Range("A15:Q15").Interior.ColorIndex = 15
Cells(15, ActiveCell.Column).Interior.ColorIndex = 45
Application.ScreenUpdating = True
End Sub[/vba]
p45cal Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.
Thanks, I appreciate that a lot. Your new version works very well. I had also noticed segments of the borders not being removed properly after releasing the filter. I had been using a clunky work around for that, but your new code takes care of it much more efficiently.
As far as the right side red border, I'm still getting that, I just tried it with excel 2003 and that's not happening. So apparently it's some sort of bug when running an .xls file in 2007
I'm using the work around of adding the command shown below in bold(inserted right before the last End if)
[vba] With TheRow.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 7
End With
End If
'Next Line removes Col K right side border that mysteriously is being added in Excel 2007, on my machine ActiveCell.Offset(0, 11 - ActiveCell.Column).Borders(xlEdgeRight).LineStyle = xlNone
End If
Range("A15:Q15").Interior.ColorIndex = 15
Cells(15, ActiveCell.Column).Interior.ColorIndex = 45
Application.ScreenUpdating = True
End Sub
[/vba] Thanks again
That line in bold is a bit convoluted, try instead, in nearly the same place:[vba] With TheRow.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 7
End With TheRow.Cells(11).Borders(xlEdgeRight).LineStyle = xlNone
End If
End If
[/vba]
p45cal Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.
For some reason when I moved this to my actual workbook (that has other procedures that also run during the Selection Change Event)
I had to change the following command
[vba]Set TheRow = Target.EntireRow.Resize(, 30)[/vba] to:
[vba]Set TheRow = Target.EntireRow.Resize(1, 30)[/vba] Without that change the code exits before coloring the borders.
I put a msgbox right before the border coloring segment, to see if the code gets that far, and it does not.
It was due to an inefficient conditional formatting that I'm using in Column B
Once I improved the 2nd condition formula I was using, this is problem went away.
see: http://www.vbaexpress.com/forum/show...412#post236412
By the way, I forgot to thankyou p45cal for that last code improvement. It works well and is certainly much cleaner than what I came up with
Edit: woops I meant to post this at my other thread. -- However it is relevant here also, so I decided to leave it.
As I was working away at stripping code and data and many of the sheets out of the workbook to reduce it's size so that I could post a sample, I stumbled across what was causing the issue.
Here is how the code was:
[vba]
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Static TheRow As Range
Dim cll As Range
Dim Lastrow As Long
If TheRow Is Nothing Then
With Range("A16:AD" & Lastrow)
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
Else
For Each cll In TheRow.Cells
cll.Borders(xlEdgeTop).LineStyle = xlNone
cll.Borders(xlEdgeBottom).LineStyle = xlNone
Next cll
End If
If ActiveCell.Row > 15 Then
If Target.Rows.Count = 1 Then
Application.ScreenUpdating = False
Set TheRow = Target.EntireRow.Resize(, 30)
With TheRow.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 7
End With
With TheRow.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 7
End With
TheRow.Cells(14).Borders(xlEdgeRight).LineStyle = xlNone
End If
End If
End Sub[/vba] In the version below you can see that I moved Application.ScreenUpdating = False farther up in the code.
I understand why it's much better there, but it makes no sense to me why the events only fire slowly when conditional formatting is used
[vba]
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Static TheRow As Range
Dim cll As Range
Dim Lastrow As Long
If TheRow Is Nothing Then
With Range("A16:AD" & Lastrow)
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
Else
For Each cll In TheRow.Cells
cll.Borders(xlEdgeTop).LineStyle = xlNone
cll.Borders(xlEdgeBottom).LineStyle = xlNone
Next cll
End If
If ActiveCell.Row > 15 Then
If Target.Rows.Count = 1 Then
Set TheRow = Target.EntireRow.Resize(, 30)
With TheRow.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 7
End With
With TheRow.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 7
End With
TheRow.Cells(14).Borders(xlEdgeRight).LineStyle = xlNone
End If
End If
End Sub[/vba]
To make sure that I've explained correctly, ONLY with the 2nd version of code shown above, I now am able to use conditional formatting without it affecting my selection event code
If you'd like I can finish up with the stripping down the workbook, so you'll be able to see for yourself.
Do you also have a Worksheet_Change event in the sheet's code module or a Workbook_SheetChange event in the ThisWorkbook's code module?
If so, then each time the macro changes the sheet, it will trigger another event. This can get into huge numbers of nested events.
Your code makes lots of changes in:
[vba]Cells(10, 1).Value = Target.EntireRow.Cells(1).Value
Cells(10, 2).Value = Target.EntireRow.Cells(2).Value
Cells(10, 3).Value = Target.EntireRow.Cells(3).Value
…
…
etc.[/vba] which (untested) should be possible in one line:
[vba]Range("A10:W10").Value = Target.EntireRow.Cells(1).Resize(23).Value[/vba]
But try temporarily disabling events with: Application.EnableEvents = False at the beginning and a Application.EnableEvents = True at the end.
If this speeds it up then we can insert some slicker code to prevent (briefly) events from triggering while the macro is working.
ps. If you break and reset the code while EnableEvents is set to false, you will have manually to reset it to true in the immediate pane in order for the events to trigger once again.
p45cal Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.
Here is the version where I have the screen updating set to false too far down in the code, causing it to run slow.
The main thing that perplexes me is how the conditional formatting effects that. -- If I removed the conditional formation, this same slow workbook will run fast.
Edit: see page 2 in this thread to download another sample where I removed the conditional formatting, which enables the selection change event code to run fast even though the screen updating is not located where it should be.
Reply With Quote
Thanks so much for your time.
