Private Sub Worksheet_Change(ByVal Target As Range)Dim r As Range
On Error GoTo errHandle
Application.EnableEvents = False
Application.ScreenUpdating = False
If Not Intersect(Target, Range("E3")) Is Nothing Then
If Target.Value <> "" And Target.Cells.Count = 1 Then
Application.EnableEvents = False
On Error Resume Next
Columns("A:A").Find(Target.Value, , , xlWhole, , xlNext).Select
On Error GoTo 0
Application.EnableEvents = True
End If
End If
If Target.Address = "$A$6" Then
With Sheets("INFO").Range("CG2")
If Len(.Offset(1).Value) Then
Set r = .End(xlDown).Offset(1)
With .End(xlDown).Offset(1)
.Value = UCase$(ActiveSheet.Cells(6, 1).Value)
.Interior.ColorIndex = 6
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.VerticalAlignment = xlCenter
.Borders.LineStyle = xlContinuous
.RowHeight = 19.5
.Font.Bold = True
With ActiveWorkbook.Worksheets("INFO").Sort
.SetRange Range("CG2:CG500")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End If
End With
End If
With Target
If .Column <> 13 And .Count = 1 And Not .HasFormula Then
.Value = UCase$(.Value)
End If
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub
errHandle:
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox Err.Description, vbCritical, "Error number: " & Err.Number
End Sub