Trying to Find the Maximum and Minimum values from a range set by cells containg specific value

I need to extract data from Input sheet to another sheet as shown below

Input sheet:

To new sheet to extract from Input

So I have written the following VBA Code. I getting run time error '1004' Unable to get the Match property of the worksheetfunction class in the highlighted line. And first part of the code is also slow.

Sub ExtractGeotechForces()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim sourceColumn As Range
    Dim uniqueValues As Object
    Dim cell As Range
    Dim lastRow As Long
    Dim i As Long
    
    ' Set your source and destination worksheets
    Set ws1 = ActiveSheet
    Set ws2 = ThisWorkbook.Worksheets.Add
    ws2.Name = "ForceExtract"
    
    ' Define the source column range
    lastRow = ws1.Cells(ws1.Rows.Count, "F").End(xlUp).Row
    Set sourceColumn = ws1.Range("F2:F" & lastRow)
    
    ' Create a dictionary to store unique values
    Set uniqueValues = CreateObject("Scripting.Dictionary")
    
    ' Loop through each cell in the source column
    For Each cell In sourceColumn
        If Not uniqueValues.exists(cell.Value) Then
            uniqueValues.Add cell.Value, cell.Value
        End If
    Next cell
    
    ' Transfer unique values to the destination sheet
    ws2.Cells(1, 1).Value = "Elevation"
    i = 2
    For Each Item In uniqueValues.keys
        ws2.Cells(i, 1).Value = Item
        i = i + 1
    Next Item
    
    ' Optionally, you can sort the list alphabetically
    ws2.Sort.SortFields.Clear
    ws2.Sort.SortFields.Add Key:=ws2.Range("A2:A" & uniqueValues.Count), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ws2.Sort
        .SetRange ws2.Range("A2:A" & uniqueValues.Count)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
'finding first and last row of elevation
        Dim ElevToFind As Long
        Dim ElevCount As Long
        Dim ElevfirstRow As Long
        Dim ElevlastRow As Long
        Dim j As Long
        Dim maxValue As Double
        Dim minValue As Double
        Dim ElevRange As Range
        
        Set ElevRange = ws1.Range("F:F")
        
        'Total Elev count
        ElevCount = ws2.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    For j = 2 To ElevCount
        ' Get the elvation to search
        ElevToFind = ws2.Cells(j, 1).Value
        ' Find the first row with elevation Error Line
        ***ElevfirstRow = Application.WorksheetFunction.Match(ElevToFind,ElevRange, 0)*** 
        length = Application.WorksheetFunction.CountIf(ElevRange, ElevToFind)
        ElevlastRow = ElevfirstRow + length - 1
'Find Max & Min M11 of the Elevation
        Dim M11startCell, M11endCell, M11Range As Range
        Dim M11max, M11min As Double
        Set M11startCell = ws1.Cells(ElevfirstRow, 21)
        Set M11endCell = ws1.Cells(ElevlastRow, 21)
        Set M11Range = ws1.Range(M11startCell, M11endCell)
        M11max = Application.WorksheetFunction.Max(M11Range)
        M11min = Application.WorksheetFunction.Min(M11Range)
        ws2.Cells(j, 2).Value = maxValue
        ws2.Cells(j, 3).Value = minValue
    Next j
    
    MsgBox "Forces extracted successfully!"
        
        
 End Sub   

Modified Code as per @FaneDuru code

Option Explicit
 
 Sub ExtractGeotechForces2()
  Dim ws1 As Worksheet, ws2 As Worksheet, lastRow As Long, arr, arrFin, arrIt
  Dim i As Long, dict As Object
  
  Set ws1 = ActiveSheet
  Set ws2 = ThisWorkbook.Worksheets.Add
    ws2.Name = "ForceExtract"
  
  ' Place the source column and item values in an array, for faster processing:
    lastRow = ws1.Cells(ws1.Rows.Count, "F").End(xlUp).Row
    arr = ws1.Range("F2:AD" & lastRow).Value2
    
    'load the dictionary (unique keys and all their values):
    Set dict = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(arr)
        If Not dict.Exists(arr(i, 1)) Then
            dict.Add arr(i, 1), Array(arr(i, 2), arr(i, 8), arr(i, 11), arr(i, 14), arr(i, 17), arr(i, 20), arr(i, 23))
        Else
            arrIt = dict(arr(i, 1)) 'place the item in an array to modify it
            ReDim Preserve arrIt(UBound(arrIt) + 1) 'increase the array no of elements preserving existing
            arrIt(UBound(arrIt)) = Array(arr(i, 2), arr(i, 8), arr(i, 11), arr(i, 14), arr(i, 17), arr(i, 20), arr(i, 23))  'place the value from B:B as the last array element
            dict(arr(i, 1)) = arrIt 'place back the updated array
        End If
    Next i
    
    'ReDim the necessary final array:
    ReDim arrFin(1 To dict.Count, 1 To 8)
    Dim MaxVal As Single, MinVal As Single
    For i = 0 To dict.Count - 1
        arrFin(i + 1, 1) = dict.keys()(i) 'place the dictionary key
        arrFin(i + 1, 2) = WorksheetFunction.Max(dict.Items()(i)) 'Max
        arrFin(i + 1, 3) = WorksheetFunction.Min(dict.Items()(i)) 'Min
    Next i
    'drop the processed array at once:
    ws2.Range("A1").Resize(, 3).Value = Array("ColumnA", "ColumnB", "ColumnC") 'Columns headers
    ws2.Range("A2").Resize(UBound(arrFin), UBound(arrFin, 2)).Value2 = arrFin  'Processed values
End Sub

I have modified the code to add more data from more columns (8) to dictionary need help to extarct the min and max of each columns to new sheet

Please, try the next VBA solution:

Sub ExtractGeotechForces()
  Dim ws1 As Worksheet, ws2 As Worksheet, lastRow As Long, arr, arrFin, arrIt
  Dim i As Long, dict As Object
  
  Set ws1 = ActiveSheet
  Set ws2 = ThisWorkbook.Worksheets.Add
    ws2.name = "ForceExtract"
  
  ' Place the source column and item values in an array, for faster processing:
    lastRow = ws1.cells(ws1.rows.count, "A").End(xlUp).row 'last row in A:A
    arr = ws1.Range("A2:B" & lastRow).Value2 ' place the range in an array for faster processing
    
    'load the dictionary (unique keys and all their values):
    Set dict = CreateObject("Scripting.Dictionary") 'set the dictionary
    For i = 1 To UBound(arr) 'iterate the array by rows
        If Not dict.Exists(arr(i, 1)) Then 'if the key does  not exist>
            dict.Add arr(i, 1), Array(arr(i, 2)) 'create it and place as item an array with arr(i, 2) value
        Else
            arrIt = dict(arr(i, 1)) 'place the item in an array to modify it
            ReDim Preserve arrIt(UBound(arrIt) + 1) 'increase the array no of elements preserving existing
            arrIt(UBound(arrIt)) = arr(i, 2)        'place the value from B:B as the last array element
            dict(arr(i, 1)) = arrIt 'place back the updated array
        End If
    Next i
    
    'ReDim the necessary final array:
    ReDim arrFin(1 To dict.count, 1 To 3)

    Dim MaxVal As Single, MinVal As Single
    For i = 0 To dict.count - 1 'iterate between the dictionary elements (zero based)
        arrFin(i + 1, 1) = dict.keys()(i) 'place the dictionary key
        arrFin(i + 1, 2) = WorksheetFunction.Max(dict.Items()(i)) 'Max
        arrFin(i + 1, 3) = WorksheetFunction.min(dict.Items()(i)) 'Min
    Next i
    'drop the processed array at once:
    ws2.Range("A1").Resize(, 3).value = Array("ColumnA", "ColumnB", "ColumnC") 'Columns headers
    ws2.Range("A2").Resize(UBound(arrFin), UBound(arrFin, 2)).Value2 = arrFin  'Processed values
End Sub