Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Column > 20 Then Exit Sub
On Error GoTo ErrHandler
Target.Formula = UCase(Target.Formula)
ErrHandler:
On Error Resume Next
If Not Intersect(Target, Range("c:c")) Is Nothing Then
Range("c9:i19").Sort Key1:=Range("c9:i19"), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
If Not Intersect(Target, Range("c:c")) Is Nothing Then
Range("c22:i27").Sort Key1:=Range("c22:i27"), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
On Error Resume Next
If Not Intersect(Target, Range("c:c")) Is Nothing Then
Range("c30:i41").Sort Key1:=Range("c30:i41"), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
If Not Intersect(Target, Range("c:c")) Is Nothing Then
Range("c44:i78").Sort Key1:=Range("c44:i78"), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
On Error Resume Next
If Not Intersect(Target, Range("c:c")) Is Nothing Then
Range("c81:i91").Sort Key1:=Range("c81:i91"), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
On Error Resume Next
If Not Intersect(Target, Range("c:c")) Is Nothing Then
Range("c94:i110").Sort Key1:=Range("c94:i110"), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
On Error Resume Next
If Not Intersect(Target, Range("c:c")) Is Nothing Then
Range("c113:i118").Sort Key1:=Range("c113:i118"), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
On Error Resume Next
If Not Intersect(Target, Range("c:c")) Is Nothing Then
Range("c121:i126").Sort Key1:=Range("c121:i126"), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
On Error Resume Next
If Not Intersect(Target, Range("c:c")) Is Nothing Then
Range("c129:i151").Sort Key1:=Range("c129:i151"), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
On Error Resume Next
If Not Intersect(Target, Range("c:c")) Is Nothing Then
Range("c154:i162").Sort Key1:=Range("c154:i162"), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
On Error Resume Next
If Not Intersect(Target, Range("c:c")) Is Nothing Then
Range("c165:i169").Sort Key1:=Range("c165:i169"), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
On Error Resume Next
If Not Intersect(Target, Range("c:c")) Is Nothing Then
Range("c172:i175").Sort Key1:=Range("c172:i175"), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
On Error Resume Next
If Not Intersect(Target, Range("c:c")) Is Nothing Then
Range("c178:i180").Sort Key1:=Range("c178:i180"), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
Dim WF As Object, r As Long, H As Range, U As Range
Set WF = WorksheetFunction: Application.EnableEvents = False
Set H = ActiveWorkbook.ActiveSheet.Rows.Find("*", , , , xlByRows, xlPrevious).Offset(5)
Set U = ActiveWorkbook.ActiveSheet.Rows.Find("*", , , , xlByRows, xlPrevious).Offset(5)
Application.ScreenUpdating = False
For r = ActiveWorkbook.ActiveSheet.Rows.Find("*", , , , xlByRows, xlPrevious).Row + 5 To 12 Step -1
If WF.CountA(Range(Cells(r - 1, 1), Cells(r - 1, 8))) = 0 _
And WF.CountA(Range(Cells(r, 1), Cells(r, 8))) = 0 Then _
Set H = Union(H, Cells(r, 1))
If WF.CountA(Range(Cells(r - 1, 1), Cells(r - 1, 8))) <> 0 Then _
Set U = Union(U, Cells(r, 1), Cells(r - 1))
Next r
H.EntireRow.Hidden = True: U.EntireRow.Hidden = False
Application.EnableEvents = True:
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False
Dim cell As Range
For Each cell In Range("A1:Z250")
On Error GoTo ErrHandler
If Len(cell.Comment.Text) > 0 Then
With cell.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Point1:
On Error GoTo 0
Next cell
Exit Sub
ErrHandler:
Resume Point1:
Application.EnableEvents = True
End Sub
Thx for any advice, will be appreciated !!
Bookmarks