Find the Maximum and Minimum values from a range set by cells containg specific value by VBA Array function

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

Input sheet: I have added the image of the source file from which i want to extract the data And I have hidden someww columns so that only columns from which i want to extract data are vissible

As seen from the Image Column F of solurce file has many duplicate values say 10 no of rows with value 2 but have different values in the other columns in the coresponding rows.

I want to group the other column data say (G J M P S V Y AB) to a single key value on column F say 2 and find the maximum & Minimum of each columns and extract the same to new sheet as

I have modifed some code which got help from this forum for extract similar data for just 2 columns as below

Sub ExtractGeotechForces3()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRow As Long
    Dim arr, arrFin(), arrIt
    Dim i As Long, dict As Object
    
    Set ws1 = ActiveSheet
    Set ws2 = ThisWorkbook.Worksheets.Add
    ws2.Name = "ForceExtract"
    
    lastRow = ws1.Cells(ws1.Rows.Count, "F").End(xlUp).Row
    arr = ws1.Range("F2:AD" & lastRow).Value2
    
    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))
            ReDim Preserve arrIt(UBound(arrIt) + 1)
            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))
            dict(arr(i, 1)) = arrIt
        End If
    Next i
    
    ' Adjust the size of arrFin to accommodate additional columns
    ReDim arrFin(1 To dict.Count, 1 To 15) ' 1 for elevation, 7 for max, and 7 for min
    
    Dim key As Variant, values As Variant
    For i = 1 To dict.Count
        key = dict.keys()(i - 1)
        values = dict(key)
        arrFin(i, 1) = key ' Place the key in the output array
        
        ' Loop through the values array to extract max and min for each column
        Dim j As Long, k As Long
        For j = 0 To UBound(values)
            ' Calculate maximum and minimum values for each column
            For k = 1 To 7
                arrFin(i, k * 2) = WorksheetFunction.Max(values(j)) ' Max value
                arrFin(i, k * 2 + 1) = WorksheetFunction.Min(values(j)) ' Min value
            Next k
        Next j
    Next i
    
    ' Output the results to the destination worksheet
    ws2.Range("A1").Resize(, 15).Value = Array("Elevation", "N1-Max", "N1-Min", "N2-Max", "N2-Min", "Q12-Max", "Q12-Min", "Q23-Max", "Q23-Min", "Q13-Max", "Q13-Min", "M11-Max", "M11-Min", "M22-Max", "M22-Min", "M13-Max", "M13-Min") ' Column headers
    ws2.Range("A2").Resize(UBound(arrFin), UBound(arrFin, 2)).Value2 = arrFin ' Processed values
End Sub

Now I want to extend it to multiple columns but when i try to run the programm the maximum and minimum values of same column repeates for all extracted column

Please, try the next adapted answer. It uses a constant able to keep the number of desired columns to be processed, being dynamic, from this point of view. It uses a jagged array, as I said in a comment to the other question. It works for consecutive columns, starting from "A:A".

Edited

Adapted the code to work with discontinuous columns range. Only adapted a code line and inserted to new code lines, able to extract the necessary columns in the same array, now containing only the necessary columns:

Sub ExtractGeotechForces_8Cols()
  Dim ws1 As Worksheet, ws2 As Worksheet, lastRow As Long, arr, arrFin, arrIt(), arr1(), arrJG
  Dim i As Long, j As Long, k As Long, dict As Object, lastColLetter As String
  Const retCols As Long = 8 'use here the number of columns to be processed (except the type)
  
  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 of A:A column
     
    'MODIFIED________________________________________________________________________________
    lastColLetter = "P"  'You need to place here the letter of the last column!!!  - MODIFIED!
    'END MODIFIED____________________________________________________________________________

    arr = ws1.Range("A2:" & lastColLetter & lastRow).Value2 'place the range in an array for faster processing
    
    'CODE ADDED________________________________________________________________________________________________
    Dim arrCols(): arrCols = Array(1, 3, 6, 7, 8, 9, 12, 13, 16) 'Array to keep the RELATIVE indexes
                                                                 'of the necessary columns. In my testing
                                                                 'environment I used range "A2:P" & lastR
                                                                 'and columns A,C,F,G,H,I,L,M,P
    'For initial range "F:U", using the same index coresponds to columns F,H,K,L,M,N,Q,R,U!
    If UBound(arrCols) <> retCols Then MsgBox "You did not choose an appropriate number of column indexes...": Exit Sub
    'recreate arr array to contain only consecutive columns, the one specified in the above array:
    arr = Application.index(arr, Evaluate("row(1:" & UBound(arr) & ")"), arrCols)
    'END CODE ADDED______________________________________________________________________________________

    'load the dictionary (unique keys and all their values):
    Set dict = CreateObject("Scripting.Dictionary") 'set the dictionary
    ReDim arrJG(retCols - 1) 'ReDim the Jagged arrays (array of arrays...)
    
    For i = 1 To UBound(arr) 'iterate between the arr rows:
        If Not dict.Exists(arr(i, 1)) Then
            For j = 0 To retCols - 1
                arrJG(j) = Array(arr(i, j + 2)) 'build the jagged array for each type
            Next j
            dict.Add arr(i, 1), arrJG           'add the jagged array as item
        Else
            arrIt = dict(arr(i, 1))  'place the item in an array to process/modify it
            For j = 0 To UBound(arrIt) 'iterate between arrIt elements
               arr1 = arrIt(j) 'without that, VBA does  not understand that arrIt(j) is an array...
               ReDim Preserve arr1(UBound(arr1) + 1) 'add an element to the array, preserving existing values
               arr1(UBound(arr1)) = arr(i, j + 2)    'place the arr corresponding value in the last array element
               arrIt(j) = arr1      'place back processed arr1 in arrIt array
            Next j
            dict(arr(i, 1)) = arrIt 'place back the updated arrIt array as item
        End If
    Next i
    
    'ReDim the necessary final array:
    ReDim arrFin(1 To dict.count, 1 To retCols * 2 + 1) 'the number of columns is calculated using retCols
    Dim MaxVal As Single, MinVal As Single              'declare the variables to also accept decimals
    For i = 0 To dict.count - 1                         'iterate between the dictionary elements:
        arrFin(i + 1, 1) = dict.keys()(i) 'place the dictionary key in the first array column
        k = 0                             'reinitialize the variable keeping the unique pairs (Max - Min) columns
        For j = 0 To retCols - 1 ' iterate between the number of columns (except the "Type" one)
          arrFin(i + 1, k + 2) = WorksheetFunction.Max(dict.Items()(i)(j)) 'Max
          arrFin(i + 1, k + 3) = WorksheetFunction.min(dict.Items()(i)(j)) 'Min
          k = k + 2
        Next j
    Next i
    
    'Build the columns headers:
    Dim arrH: ReDim arrH(1 To 1, 1 To retCols * 2 + 1)
    k = 1 'reinitialize this variable to keep the number of Max/Min pairs
    arrH(1, 1) = "Type" 'load first array header element
    For i = 2 To UBound(arrH, 2) 'Build headers for Min and Max
        arrH(1, i) = "Max" & k: arrH(1, i + 1) = "Min" & k
        i = i + 1: k = k + 1 'to iterate from two to two and increment the pair Max/Min variable
    Next i
    'drop the headers array content in the first row:
    ws2.Range("A1").Resize(1, UBound(arrH, 2)).value = arrH 'Columns headers
    
    'drop the processed array starting from the second row, at once:
    ws2.Range("A2").Resize(UBound(arrFin), UBound(arrFin, 2)).Value2 = arrFin  'Processed values
End Sub