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

Input sheet:

ColumnA   ColumnB
2         120
2         100
2         130
2         150
-1        70
-1        200
-1        150
-1        60

To new sheet to extract from Input

ColumnA  Max  Min
2        150  100
-1       200  60

So I have written the following VBA Code It is not working please help.

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
    Dim valueToFind As Long
    Dim lastRow2 As Long
    Dim firstElevRow As Long
    Dim lastElevRow As Long
    Dim j As Long
    Dim maxValue As Double
    Dim minValue As Double
    Dim rangeToCheck As Range
    ' Define the source column range
    lastRow2 = ws2.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    For j = 2 To lastRow2
    ' Get the elvation to search
    valueToFind = ws2.Cells(j, 1).Value
    ' Find the first row with elevation
    firstElevRow = ws1.Range("F:F").Find(What:=valueToFind, After:=ws1.Cells(2, 6), _
            LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False)
    ' Find the last row with elevation
    lastElevRow = ws1.Range("F:F").Find(What:=valueToFind, After:=ws1.Cells(2, 6), _
            LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious, MatchCase:=False).Row
    'For M11
        'Define the range to check
        Set rangeToCheck = ws1.Range(ws1.Cells(firstElevRow, 22), ws1.Cells(lastElevRow, 22))
        ' Find the maximum and minimum values within the range
        maxValue = Application.WorksheetFunction.Max(rangeToCheck)
        minValue = Application.WorksheetFunction.Min(rangeToCheck)
        ws2.Cells(j, 2).Value = maxValue
        ws2.Cells(j, 3).Value = minValue
    Next j
    
    MsgBox "Forces extracted successfully!"
    
End Sub