frank_m
12-19-2010, 12:06 AM
This routine checks to see if any cells have the thick red border missing that is surrounding the used range.
It takes a few seconds to run for 15,000 rows. Is there a way I can do this faster.
Note: I can not used the change event or any events, because some times the borders are accidentally shifted while the user is in Design mode therefore the target could not be stored in a variable.
* I've attached a sample workbook
Thanks.
Sub Check_If_Red_Borders_Exists()
Dim wks As Worksheet, rng As Range, c As Range, Temp As String
Dim ColumnLetter, Lastrow As Long
Set wks = ActiveSheet
With wks
Lastrow = .[B65536].End(xlUp).Row
Set rng = .Range(.Cells(16, 18), .Cells(Lastrow, 18))
Application.ScreenUpdating = False
'Check used range right side thick red column border
For Each c In rng
If c.Borders(xlEdgeLeft).Weight <> xlThick Then
Temp = Temp & ";" & c.Row 'v
End If
Next c
'Check Botton Row thick red border
Set rng = .Range(.Cells(Lastrow, 1), .Cells(Lastrow, 17))
For Each c In rng
If c.Borders(xlEdgeBottom).LineStyle = xlNone Then
ColumnLetter = Chr(c.Column + 64)
MsgBox "E R R O R -- Column (" & ColumnLetter & ") cell/cells inserted causing" _
& "corrupted data in the DATA Sheet. ->Notify administrator.", vbCritical
End If
Next c
End With
Application.ScreenUpdating = True
On Error Resume Next
MsgBox "E R R O R -- Row/s (" & Right(Trim(Temp), Len(Trim(Temp)) - 1) & _
") missing right side red border/s in the DATA Sheet." _
& "Data Corruption Likely." & vbNewLine & _
"->Notify the administrator", vbCritical
End Sub
It takes a few seconds to run for 15,000 rows. Is there a way I can do this faster.
Note: I can not used the change event or any events, because some times the borders are accidentally shifted while the user is in Design mode therefore the target could not be stored in a variable.
* I've attached a sample workbook
Thanks.
Sub Check_If_Red_Borders_Exists()
Dim wks As Worksheet, rng As Range, c As Range, Temp As String
Dim ColumnLetter, Lastrow As Long
Set wks = ActiveSheet
With wks
Lastrow = .[B65536].End(xlUp).Row
Set rng = .Range(.Cells(16, 18), .Cells(Lastrow, 18))
Application.ScreenUpdating = False
'Check used range right side thick red column border
For Each c In rng
If c.Borders(xlEdgeLeft).Weight <> xlThick Then
Temp = Temp & ";" & c.Row 'v
End If
Next c
'Check Botton Row thick red border
Set rng = .Range(.Cells(Lastrow, 1), .Cells(Lastrow, 17))
For Each c In rng
If c.Borders(xlEdgeBottom).LineStyle = xlNone Then
ColumnLetter = Chr(c.Column + 64)
MsgBox "E R R O R -- Column (" & ColumnLetter & ") cell/cells inserted causing" _
& "corrupted data in the DATA Sheet. ->Notify administrator.", vbCritical
End If
Next c
End With
Application.ScreenUpdating = True
On Error Resume Next
MsgBox "E R R O R -- Row/s (" & Right(Trim(Temp), Len(Trim(Temp)) - 1) & _
") missing right side red border/s in the DATA Sheet." _
& "Data Corruption Likely." & vbNewLine & _
"->Notify the administrator", vbCritical
End Sub