Macro to PRIORITISE and CONSOLIDATE data across different sheets into summary sheet

I have a work book that contains surveys from three different sites. Im trying to get a macro to prioritise the data by its condition and copy the data onto a summary sheet at the beginning. I don't want the original data to be altered.

Basically the summary would be all grade D4 down to A1, then the next site in order of grade and so on. I'm really struggling to figure out how to search for the data let alone copy it.

I would appreciate a point in the right direction or if your kind enough to solve it you would be a hero

thank you in advance


JimCondition Survey template.xls

Sub RunME()
Dim ws1 As Worksheet:   Set ws1 = Sheets("Summary")
Dim wksht As Worksheet
Dim LR As Long, StartRow As Long, LastRow As Long

Application.ScreenUpdating = False

ws1.UsedRange.Delete Shift:=xlUp

For Each wksht In Worksheets
    If Not wksht.Name = ws1.Name Then
        With ws1.Range("A" & Rows.Count).End(xlUp).Offset(2, 0)
            .Value = wksht.Name
            .Font.Bold = True
        End With
    
        LR = wksht.Range("E" & Rows.Count).End(xlUp).Row
        StartRow = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
            wksht.Range("A5:M" & LR).Copy Destination:=ws1.Range("A" & StartRow)
        LastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row
        ws1.Sort.SortFields.Clear
        ws1.Sort.SortFields.Add Key:=Range("E" & StartRow, "E" & LastRow) _
            , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        ws1.Sort.SortFields.Add Key:=Range("F" & StartRow, "F" & LastRow) _
            , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        With ws1.Sort
            .SetRange Range("A" & StartRow, "M" & LastRow)
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    'delete unneeded rows
    ws1.Range("A" & ws1.Range("E" & Rows.Count).End(xlUp).Offset(1, 0).Row, "A" & ws1.Range("A" & Rows.Count).End(xlUp).Row).EntireRow.Delete Shift:=xlUp
    End If
Next wksht
 
Application.ScreenUpdating = True

End Sub

I have no idea how that works but it does, Thanks a lot. How could I possibly divide that up further? for example in each line there is a fee in either year 1, year 2, year 3..... how could I then separate it out across different sheets so there would be a tab for each year, obviously some items would be copied several times as they are present in each year?


Many Thanks

Sub RunME()
Dim ws1 As Worksheet:   Set ws1 = Sheets("Summary")
Dim wksht As Worksheet, check1 As Worksheet, check2 As Worksheet, check3 As Worksheet, check4 As Worksheet, check5 As Worksheet, tSheet As Worksheet
Dim myRange As Range, icell As Range, rCell As Range
Dim LR As Long, StartRow As Long, LastRow As Long

Application.ScreenUpdating = False

ws1.UsedRange.Delete Shift:=xlUp

For Each wksht In Worksheets
    If Not wksht.Name = ws1.Name Then
        With ws1.Range("A" & Rows.Count).End(xlUp).Offset(2, 0)
            .Value = wksht.Name
            .Font.Bold = True
        End With
    
        LR = wksht.Range("E" & Rows.Count).End(xlUp).Row
        StartRow = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
            wksht.Range("A5:M" & LR).Copy Destination:=ws1.Range("A" & StartRow)
        LastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row
        ws1.Sort.SortFields.Clear
        ws1.Sort.SortFields.Add Key:=Range("E" & StartRow, "E" & LastRow) _
            , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        ws1.Sort.SortFields.Add Key:=Range("F" & StartRow, "F" & LastRow) _
            , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        With ws1.Sort
            .SetRange Range("A" & StartRow, "M" & LastRow)
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    'delete unneeded rows
    ws1.Range("A" & ws1.Range("E" & Rows.Count).End(xlUp).Offset(1, 0).Row, "A" & ws1.Range("A" & Rows.Count).End(xlUp).Row).EntireRow.Delete Shift:=xlUp
    End If
Next wksht

'separate into years
'columns H though L (Year 1 through 5) (column 8 to 12)
'create new sheet for each year
'LastRow should still be a valid reference
'use loop to run though each row, resize and define the range, loop through defined range and copy row

Set check1 = Nothing: Set check2 = Nothing: Set check3 = Nothing: Set check4 = Nothing: Set check5 = Nothing

On Error Resume Next
    Set check1 = Sheets("Year 1")
    Set check2 = Sheets("Year 2")
    Set check3 = Sheets("Year 3")
    Set check4 = Sheets("Year 4")
    Set check5 = Sheets("Year 5")
On Error GoTo 0

If check1 Is Nothing Then Worksheets.Add(After:=Sheets(Worksheets.Count)).Name = "Year 1"
If check2 Is Nothing Then Worksheets.Add(After:=Sheets(Worksheets.Count)).Name = "Year 2"
If check3 Is Nothing Then Worksheets.Add(After:=Sheets(Worksheets.Count)).Name = "Year 3"
If check4 Is Nothing Then Worksheets.Add(After:=Sheets(Worksheets.Count)).Name = "Year 4"
If check5 Is Nothing Then Worksheets.Add(After:=Sheets(Worksheets.Count)).Name = "Year 5"

For Each icell In ws1.Range("A4:A" & LastRow)
    Set myRange = ws1.Range("H" & icell.Row, "L" & icell.Row)
        For Each rCell In myRange
            If Not IsEmpty(rCell) Then
                Select Case rCell.Column
                    Case Is = 8
                        Set tSheet = Sheets("Year 1")
                    Case Is = 9
                        Set tSheet = Sheets("Year 2")
                    Case Is = 10
                        Set tSheet = Sheets("Year 3")
                    Case Is = 11
                        Set tSheet = Sheets("Year 4")
                    Case Is = 12
                        Set tSheet = Sheets("Year 5")
                End Select
                ws1.Range("A" & rCell.Row).EntireRow.Copy Destination:=tSheet.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            End If
        Next rCell
Next icell
                        
Application.ScreenUpdating = True

End Sub

Thanks again. but how would you copy only the details about each line and the value for that year as opposed to all of the values?

Thanks for your help your a life saver as I have about 40 surveys to edit and this is saving me a whole heap of time!