Copying Data from Sheet 1 to Sheet 2 and adding rows- Code Needed

[bamaisgreat]

Starting at A17 on Sheet 1 I have a row of data that I need the data from columns A,B,C,D and G (Column B is a specific ship date) copied to one of the ranges in sheet 2 that contain the 4 quaters of the year. The date in coulmn B determines which range of the quartely ranges it goes into. On sheet 2 the 4 quaters of the year 1st Quater Jan-March 2024 Range A4-Q4, 2nd Quarter April-June 2024 Range A6-Q6, 3rd Quarter July-Sep 2024 Range A8-Q8, 4th Quarter Oct-Dec 2024 Range A8-Q10. Once the data has been entered on sheet 1 I need it add another row with the same formatting as the row above it so the next line of data can be entered. On sheet 2 I also need a row added with the same formatting as the row above it to which ever quaterly ranges the data was copied into.

 

[mumps]

I've added a line of code to insert the formula in column F. Keep in mind that the formula will return with an error until you enter values in columns I,K,M,O & Q .

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("2024 Sch")
    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
            .Range("F" & fnd.Row + 1).Formula = "=AVERAGE(I" & fnd.Row + 1 & ",K" & fnd.Row + 1 & ",M" & fnd.Row + 1 & ",O" & fnd.Row + 1 & ",Q" & fnd.Row + 1 & ")"
            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