Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
If Target.Column <> 2 Then Exit Sub
Application.ScreenUpdating = False
Dim proj As Range, fnd As Range, desWS As Worksheet, Val As String, x As Long
Set desWS = Sheets("Sheet2")
Select Case True
Case Target >= DateSerial(Year(Date) + 1, 1, 1)
Val = "5th"
Case Target >= DateSerial(Year(Target), 1, 1) And Target <= DateSerial(Year(Target), 3, 31)
Val = "1st"
Case Target >= DateSerial(Year(Target), 4, 1) And Target <= DateSerial(Year(Target), 6, 30)
Val = "2nd"
Case Target >= DateSerial(Year(Target), 7, 1) And Target <= DateSerial(Year(Target), 9, 30)
Val = "3rd"
Case Target >= DateSerial(Year(Target), 10, 1) And Target <= DateSerial(Year(Target), 12, 31)
Val = "4th"
End Select
With desWS
Set proj = .Range("A:A").Find(Target.Offset(, -1), LookIn:=xlValues, lookat:=xlWhole)
If proj Is Nothing Then
Set fnd = .Range("G:G").Find(Val, LookIn:=xlValues, lookat:=xlPart)
.Rows(fnd.Row + 1).EntireRow.Insert
.Rows(fnd.Row + 1).Interior.ColorIndex = xlNone
Range("A" & Target.Row).Resize(, 4).Copy .Range("A" & fnd.Row + 1)
Range("G" & Target.Row).Copy .Range("G" & fnd.Row + 1)
.Range("D" & fnd.Row + 1).HorizontalAlignment = xlCenter
x = .Range("A" & fnd.Row + 1 & ":A" & .Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row - 1
With desWS.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A" & fnd.Row + 1 & ":A" & x), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A" & fnd.Row + 1 & ":Q" & x)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Else
Range("A" & Target.Row).Resize(, 4).Copy .Range("A" & proj.Row)
Range("G" & Target.Row).Copy .Range("G" & proj.Row)
.Range("D" & proj.Row).HorizontalAlignment = xlCenter
End If
End With
Application.ScreenUpdating = True
End Sub
